'FREESIDE_1_7_BRANCH'.
+++ /dev/null
-- broadband (dsl/wireless) tracking, etc etc
-- Extended description on invoice for time/data charges
-- Multiple, named taxes
-- */*FIX
-- extended reported and graphing
-- integrated RT ticketing system
-- one-time payments (in signup server too). DCRD and DCHK on-demand payment types
-- credit report
-- reseller interface
-
-1.5.0pre6:
-- RADIUS session viewing
-- Major updates for reseller interface
-- Credit card and ACH refunds (w/supported processor module)
-- Proper email payment receipts (not invoice copies)
-- modular price plans, rewrote package add/edit page
-- fixed up tax report - should be correct for edge cases with named taxes,
- tax classes, etc.
-- Documentation updates
-
-1.5.7:
-- version numbering change, now even/odd like Perl or Linux
-- fix bug that could cause mis-billing on upgrades! (new installs ok)
-- updated install documentation
-- historical late notice viewing in web interface
-- VoIP billing for CDRs from RADIUS
-- promotional codes for signup
-- lots of RT integration, integrated RT upgraded to 3.2.2, preliminary RT
- add-on docs
-- one-time referral credits
-- invoices now use history records (don't lose details)
-- option to credit for remaining service upon package cancel/change
- (peter bowen)
-- one-time registration codes
-- "selfservice_server-session_module" config value can be set to
- "Cache::FileCache" on FreeBSD or elsewhere IPC::ShareLite has trouble.
-- package changes don't re-charge setup fee
-- per-agent payment and credit reports
-- CSV and Excel export of most reports, others to be migrated to new report template
-- prepaid card support updated: now includes a web generator, agent-specific
- prepaid cards, and creates *payments*, not credits
-- preliminary setup for Slony-1 PostgreSQL replication
-- reformatted latex invoice templates w/Text::Template (khoff) and removed
- some useless fields (quantity/unit price)
-- simplified upgrade instructions
-- add export to vpopmail SQL
-- html invoices
-- big self-service updates (recharge w/prepaid card, change info, more)
-- significant freeside-daily speedup
-
-notyet (1.5.8?):
-- account merging UI in exports (for example, to consolidate passwd files from
- multiple servers)
-
package FS::Conf;
-use vars qw($base_dir @config_items @card_types $DEBUG );
-use MIME::Base64;
+use vars qw($default_dir $base_dir @config_items @card_types $DEBUG );
+use IO::File;
+use File::Basename;
use FS::ConfItem;
use FS::ConfDefaults;
-use FS::conf;
-use FS::Record qw(qsearch qsearchs);
-use FS::UID qw(dbh);
$base_dir = '%%%FREESIDE_CONF%%%';
+$default_dir = '%%%FREESIDE_CONF%%%';
$DEBUG = 0;
use FS::Conf;
+ $conf = new FS::Conf "/config/directory";
+
+ $FS::Conf::default_dir = "/config/directory";
$conf = new FS::Conf;
+ $dir = $conf->dir;
+
$value = $conf->config('key');
@list = $conf->config('key');
$bool = $conf->exists('key');
=over 4
-=item new
+=item new [ DIRECTORY ]
-Create a new configuration object.
+Create a new configuration object. A directory arguement is required if
+$FS::Conf::default_dir has not been set.
=cut
sub new {
- my($proto) = @_;
+ my($proto,$dir) = @_;
my($class) = ref($proto) || $proto;
- my($self) = { 'base_dir' => $base_dir };
+ my($self) = { 'dir' => $dir || $default_dir,
+ 'base_dir' => $base_dir,
+ };
bless ($self, $class);
}
+=item dir
+
+Returns the conf directory.
+
+=cut
+
+sub dir {
+ my($self) = @_;
+ my $dir = $self->{dir};
+ -e $dir or die "FATAL: $dir doesn't exist!";
+ -d $dir or die "FATAL: $dir isn't a directory!";
+ -r $dir or die "FATAL: Can't read $dir!";
+ -x $dir or die "FATAL: $dir not searchable (executable)!";
+ $dir =~ /^(.*)$/;
+ $1;
+}
+
=item base_dir
Returns the base directory. By default this is /usr/local/etc/freeside.
=cut
-sub _config {
- my($self,$name,$agent)=@_;
- my $hashref = { 'name' => $name };
- if (defined($agent) && $agent) {
- $hashref->{agent} = $agent;
- }
- local $FS::Record::conf = undef; # XXX evil hack prevents recursion
- my $cv = FS::Record::qsearchs('conf', $hashref);
- if (!$cv && exists($hashref->{agent})) {
- delete($hashref->{agent});
- $cv = FS::Record::qsearchs('conf', $hashref);
- }
- return $cv;
-}
-
sub config {
- my($self,$name,$agent)=@_;
- my $cv = $self->_config($name, $agent) or return;
-
+ my($self,$file)=@_;
+ my($dir)=$self->dir;
+ my $fh = new IO::File "<$dir/$file" or return;
if ( wantarray ) {
- split "\n", $cv->value;
+ map {
+ /^(.*)$/
+ or die "Illegal line (array context) in $dir/$file:\n$_\n";
+ $1;
+ } <$fh>;
} else {
- (split("\n", $cv->value))[0];
+ <$fh> =~ /^(.*)$/
+ or die "Illegal line (scalar context) in $dir/$file:\n$_\n";
+ $1;
}
}
=cut
sub config_binary {
- my($self,$name,$agent)=@_;
- my $cv = $self->_config($name, $agent) or return;
- decode_base64($cv->value);
+ my($self,$file)=@_;
+ my($dir)=$self->dir;
+ my $fh = new IO::File "<$dir/$file" or return;
+ local $/;
+ my $content = <$fh>;
+ $content;
}
=item exists KEY
=cut
sub exists {
- my($self,$name,$agent)=@_;
- defined($self->_config($name, $agent));
+ my($self,$file)=@_;
+ my($dir) = $self->dir;
+ -e "$dir/$file";
}
=item config_orbase KEY SUFFIX
=cut
sub config_orbase {
- my( $self, $name, $suffix ) = @_;
- if ( $self->exists("${name}_$suffix") ) {
- $self->config("${name}_$suffix");
+ my( $self, $file, $suffix ) = @_;
+ if ( $self->exists("${file}_$suffix") ) {
+ $self->config("${file}_$suffix");
} else {
- $self->config($name);
+ $self->config($file);
}
}
=cut
sub touch {
- my($self, $name, $agent) = @_;
- $self->set($name, '', $agent);
+ my($self, $file) = @_;
+ my $dir = $self->dir;
+ unless ( $self->exists($file) ) {
+ warn "[FS::Conf] TOUCH $file\n" if $DEBUG;
+ system('touch', "$dir/$file");
+ }
}
=item set KEY VALUE
=cut
sub set {
- my($self, $name, $value, $agent) = @_;
+ my($self, $file, $value) = @_;
+ my $dir = $self->dir;
$value =~ /^(.*)$/s;
$value = $1;
-
- warn "[FS::Conf] SET $file\n" if $DEBUG;
-
- my $old = FS::Record::qsearchs('conf', {name => $name, agent => $agent});
- my $new = new FS::conf { $old ? $old->hash
- : ('name' => $name, 'agent' => $agent)
- };
- $new->value($value);
-
- my $error;
- if ($old) {
- $error = $new->replace($old);
- } else {
- $error = $new->insert;
+ unless ( join("\n", @{[ $self->config($file) ]}) eq $value ) {
+ warn "[FS::Conf] SET $file\n" if $DEBUG;
+# warn "$dir" if is_tainted($dir);
+# warn "$dir" if is_tainted($file);
+ chmod 0644, "$dir/$file";
+ my $fh = new IO::File ">$dir/$file" or return;
+ chmod 0644, "$dir/$file";
+ print $fh "$value\n";
}
-
- die "error setting configuration value: $error \n"
- if $error;
-
-}
-
-=item set_binary KEY VALUE
-
-Sets the specified configuration key to an exact scalar value which
-can be retrieved with config_binary.
-
-=cut
-
-sub set_binary {
- my($self,$name, $value, $agent)=@_;
- $self->set($name, encode_base64($value), $agent);
}
+#sub is_tainted {
+# return ! eval { join('',@_), kill 0; 1; };
+# }
=item delete KEY
=cut
sub delete {
- my($self, $name, $agent) = @_;
- if ( my $cv = FS::Record::qsearchs('conf', {name => $name, agent => $agent}) ) {
+ my($self, $file) = @_;
+ my $dir = $self->dir;
+ if ( $self->exists($file) ) {
warn "[FS::Conf] DELETE $file\n";
-
- my $oldAutoCommit = $FS::UID::AutoCommit;
- local $FS::UID::AutoCommit = 0;
- my $dbh = dbh;
-
- my $error = $cv->delete;
-
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- die "error setting configuration value: $error \n"
- }
-
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;
-
+ unlink "$dir/$file";
}
}
#quelle kludge
@config_items,
( map {
+ my $basename = basename($_);
+ $basename =~ /^(.*)$/;
+ $basename = $1;
new FS::ConfItem {
- 'key' => $_->name,
+ 'key' => $basename,
'section' => 'billing',
'description' => 'Alternate template file for invoices. See the <a href="../docs/billing.html">billing documentation</a> for details.',
'type' => 'textarea',
}
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'invoice!_template!_%' ESCAPE '!'")
+ } glob($self->dir. '/invoice_template_*')
),
( map {
+ my $basename = basename($_);
+ $basename =~ /^(.*)$/;
+ $basename = $1;
new FS::ConfItem {
- 'key' => '$_->name',
- 'section' => 'billing', #?
- 'description' => 'An image to include in some types of invoices',
- 'type' => 'binary',
- }
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'logo!_%.png' ESCAPE '!'")
- ),
- ( map {
- new FS::ConfItem {
- 'key' => $_->name,
+ 'key' => $basename,
'section' => 'billing',
'description' => 'Alternate HTML template for invoices. See the <a href="../docs/billing.html">billing documentation</a> for details.',
'type' => 'textarea',
}
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'invoice!_html!_%' ESCAPE '!'")
+ } glob($self->dir. '/invoice_html_*')
),
( map {
- ($latexname = $_->name ) =~ s/latex/html/;
+ my $basename = basename($_);
+ $basename =~ /^(.*)$/;
+ $basename = $1;
+ ($latexname = $basename ) =~ s/latex/html/;
new FS::ConfItem {
- 'key' => $_->name,
+ 'key' => $basename,
'section' => 'billing',
'description' => "Alternate Notes section for HTML invoices. Defaults to the same data in $latexname if not specified.",
'type' => 'textarea',
}
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'invoice!_htmlnotes!_%' ESCAPE '!'")
+ } glob($self->dir. '/invoice_htmlnotes_*')
),
( map {
+ my $basename = basename($_);
+ $basename =~ /^(.*)$/;
+ $basename = $1;
new FS::ConfItem {
- 'key' => $_->name,
+ 'key' => $basename,
'section' => 'billing',
'description' => 'Alternate LaTeX template for invoices. See the <a href="../docs/billing.html">billing documentation</a> for details.',
'type' => 'textarea',
}
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'invoice!_latex!_%' ESCAPE '!'")
- ),
- ( map {
- new FS::ConfItem {
- 'key' => '$_->name',
- 'section' => 'billing', #?
- 'description' => 'An image to include in some types of invoices',
- 'type' => 'binary',
- }
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'logo!_%.eps' ESCAPE '!'")
+ } glob($self->dir. '/invoice_latex_*')
),
( map {
+ my $basename = basename($_);
+ $basename =~ /^(.*)$/;
+ $basename = $1;
new FS::ConfItem {
- 'key' => $_->name,
+ 'key' => $basename,
'section' => 'billing',
'description' => 'Alternate Notes section for LaTeX typeset PostScript invoices. See the <a href="../docs/billing.html">billing documentation</a> for details.',
'type' => 'textarea',
}
- } FS::Record::qsearch('conf', {}, '', "WHERE name LIKE 'invoice!_latexnotes!_%' ESCAPE '!'")
+ } glob($self->dir. '/invoice_latexnotes_*')
);
}
'type' => 'checkbox',
},
+ #these should become per-user...
+ {
+ 'key' => 'vonage-username',
+ 'section' => '',
+ 'description' => 'Vonage Click2Call username (see <a href="https://secure.click2callu.com/">https://secure.click2callu.com/</a>)',
+ 'type' => 'text',
+ },
+ {
+ 'key' => 'vonage-password',
+ 'section' => '',
+ 'description' => 'Vonage Click2Call username (see <a href="https://secure.click2callu.com/">https://secure.click2callu.com/</a>)',
+ 'type' => 'text',
+ },
+ {
+ 'key' => 'vonage-fromnumber',
+ 'section' => '',
+ 'description' => 'Vonage Click2Call number (see <a href="https://secure.click2callu.com/">https://secure.click2callu.com/</a>)',
+ 'type' => 'text',
+ },
+
{
'key' => 'echeck-nonus',
'section' => 'billing',
},
{
- 'key' => 'logo.png',
- 'section' => 'billing', #?
- 'description' => 'An image to include in some types of invoices',
- 'type' => 'binary',
- },
-
- {
- 'key' => 'logo.eps',
- 'section' => 'billing', #?
- 'description' => 'An image to include in some types of invoices',
- 'type' => 'binary',
- },
-
- {
- 'key' => 'selfservice-ignore_quantity',
- 'section' => '',
- 'description' => 'Ignores service quantity restrictions in self-service context. Strongly not recommended - just set your quantities correctly in the first place.',
- 'type' => 'checkbox',
- },
-
- {
'key' => 'disable_setup_suspended_pkgs',
'section' => 'billing',
'description' => 'Disables charging of setup fees for suspended packages.',
}
$cust_main->ncancelled_pkgs
) {
- my $action = $cust_pkg->part_pkg->option('recur_action') || 'suspend';
- my $error = $cust_pkg->$action();
+ my $error = $cust_pkg->suspend;
warn "Error suspending package ". $cust_pkg->pkgnum.
" for custnum ". $cust_main->custnum.
": $error"
}
}
-=item ut_sfloat COLUMN
-
-Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
-May not be null. If there is an error, returns the error, otherwise returns
-false.
-
-=cut
-
-sub ut_sfloat {
- my($self,$field)=@_ ;
- ($self->getfield($field) =~ /^(-?\d+\.\d+)$/ ||
- $self->getfield($field) =~ /^(-?\d+)$/ ||
- $self->getfield($field) =~ /^(-?\d+\.\d+[eE]-?\d+)$/ ||
- $self->getfield($field) =~ /^(-?\d+[eE]-?\d+)$/)
- or return "Illegal or empty (float) $field: ". $self->getfield($field);
- $self->setfield($field,$1);
- '';
-}
-=item ut_sfloatn COLUMN
-
-Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
-null. If there is an error, returns the error, otherwise returns false.
-
-=cut
-
-sub ut_sfloatn {
- my( $self, $field ) = @_;
- if ( $self->getfield($field) =~ /^()$/ ) {
- $self->setfield($field,'');
- '';
- } else {
- $self->ut_sfloat($field);
- }
-}
-
=item ut_snumber COLUMN
Check/untaint signed numeric data (whole numbers). If there is an error,
'svc_acct' => {
'columns' => [
'svcnum', 'int', '', '', '', '',
- 'username', 'varchar', '', $username_len, '', '',
- '_password', 'varchar', '', 512, '', '',
- '_password_encoding', 'varchar', 'NULL', $char_d, '', '',
+ 'username', 'varchar', '', $username_len, '', '', #unique (& remove dup code)
+ '_password', 'varchar', '', 72, '', '', #13 for encryped pw's plus ' *SUSPENDED* (md5 passwords can be 34, blowfish 60)
'sec_phrase', 'varchar', 'NULL', $char_d, '', '',
'popnum', 'int', 'NULL', '', '', '',
'uid', 'int', 'NULL', '', '', '',
'index' => [],
},
- 'conf' => {
- 'columns' => [
- 'confnum', 'serial', '', '', '', '',
- 'agentnum', 'int', 'NULL', '', '', '',
- 'name', 'varchar', '', $char_d, '', '',
- 'value', 'varchar', 'NULL', '', '', '', # Pg specific
- ],
- 'primary_key' => 'confnum',
- 'unique' => [ [ 'agentnum', 'name' ]],
- 'index' => [],
- },
-
# name type nullability length default local
#'new_table' => {
use vars qw(
@ISA @EXPORT_OK $cgi $dbh $freeside_uid $user
$conf_dir $secrets $datasrc $db_user $db_pass %callback @callback
- $driver_name $AutoCommit $callback_hack
+ $driver_name $AutoCommit
);
use subs qw(
getsecrets cgisetotaker
use Exporter;
use Carp qw(carp croak cluck confess);
use DBI;
-use IO::File;
+use FS::Conf;
use FS::CurrentUser;
@ISA = qw(Exporter);
$conf_dir = "%%%FREESIDE_CONF%%%/";
$AutoCommit = 1; #ours, not DBI
-$callback_hack = 0;
=head1 NAME
FS::CurrentUser->load_user($user);
- unless($callback_hack) {
- foreach ( keys %callback ) {
- &{$callback{$_}};
- # breaks multi-database installs # delete $callback{$_}; #run once
- }
-
- &{$_} foreach @callback;
+ foreach ( keys %callback ) {
+ &{$callback{$_}};
+ # breaks multi-database installs # delete $callback{$_}; #run once
}
+ &{$_} foreach @callback;
+
$dbh;
}
sub getsecrets {
my($setuser) = shift;
$user = $setuser if $setuser;
+ my($conf) = new FS::Conf $conf_dir;
- if ( -e "$conf_dir/mapsecrets" ) {
+ if ( $conf->exists('mapsecrets') ) {
die "No user!" unless $user;
- my($line) = grep /^\s*($user|\*)\s/,
- map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/mapsecrets");
+ my($line) = grep /^\s*($user|\*)\s/, $conf->config('mapsecrets');
confess "User $user not found in mapsecrets!" unless $line;
$line =~ /^\s*($user|\*)\s+(.*)$/;
$secrets = $2;
$secrets = 'secrets';
}
- ($datasrc, $db_user, $db_pass) =
- map { /^(.*)$/; $1 } readline(new IO::File "$conf_dir/$secrets")
- or die "Can't get secrets: $secrets: $!\n";
+ ($datasrc, $db_user, $db_pass) = $conf->config($secrets)
+ or die "Can't get secrets: $secrets: $!\n";
+ $FS::Conf::default_dir = $conf_dir. "/conf.$datasrc";
undef $driver_name;
($datasrc, $db_user, $db_pass);
}
+++ /dev/null
-package FS::conf;
-
-use strict;
-use vars qw( @ISA );
-use FS::Record qw( qsearch qsearchs );
-
-@ISA = qw(FS::Record);
-
-=head1 NAME
-
-FS::conf - Object methods for conf records
-
-=head1 SYNOPSIS
-
- use FS::conf;
-
- $record = new FS::conf \%hash;
- $record = new FS::conf { 'column' => 'value' };
-
- $error = $record->insert;
-
- $error = $new_record->replace($old_record);
-
- $error = $record->delete;
-
- $error = $record->check;
-
-=head1 DESCRIPTION
-
-An FS::conf object represents a configuration value. FS::conf inherits from
-FS::Record. The following fields are currently supported:
-
-=over 4
-
-=item confnum - primary key
-
-=item agentnum - the agent to which this configuration value applies
-
-=item name - the name of the configuration value
-
-=item value - the configuration value
-
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item new HASHREF
-
-Creates a new configuration value. To add the example to the database, see L<"insert">.
-
-Note that this stores the hash reference, not a distinct copy of the hash it
-points to. You can ask the object for a copy with the I<hash> method.
-
-=cut
-
-sub table { 'conf'; }
-
-=item insert
-
-Adds this record to the database. If there is an error, returns the error,
-otherwise returns false.
-
-=cut
-
-=item delete
-
-Delete this record from the database.
-
-=cut
-
-=item replace OLD_RECORD
-
-Replaces the OLD_RECORD with this one in the database. If there is an error,
-returns the error, otherwise returns false.
-
-=cut
-
-=item check
-
-Checks all fields to make sure this is a valid configuration value. If there is
-an error, returns the error, otherwise returns false. Called by the insert
-and replace methods.
-
-=cut
-
-sub check {
- my $self = shift;
-
- my $error =
- $self->ut_numbern('confnum')
- || $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum')
- || $self->ut_text('name')
- || $self->ut_anything('value')
- ;
- return $error if $error;
-
- $self->SUPER::check;
-}
-
-=back
-
-=head1 BUGS
-
-=head1 SEE ALSO
-
-L<FS::Record>, schema.html from the base documentation.
-
-=cut
-
-1;
-
=item print_latex [ TIME [ , TEMPLATE ] ]
Internal method - returns a filename of a filled-in LaTeX template for this
-invoice (Note: add ".tex" to get the actual filename), and a filename of
-an associated logo (with the .eps extension included).
+invoice (Note: add ".tex" to get the actual filename).
See print_ps and print_pdf for methods that return PostScript and PDF output.
'quantity' => 1,
'terms' => $conf->config('invoice_default_terms') || 'Payable upon receipt',
#'notes' => join("\n", $conf->config('invoice_latexnotes') ),
- # better hang on to conf_dir for a while
'conf_dir' => "$FS::UID::conf_dir/conf.$FS::UID::datasrc",
);
}
my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
- my $lh = new File::Temp( TEMPLATE => 'invoice.'. $self->invnum. '.XXXXXXXX',
- DIR => $dir,
- SUFFIX => '.eps',
- UNLINK => 0,
- ) or die "can't open temp file: $!\n";
-
- if ($template && $conf->exists("logo_${template}.eps")) {
- print $lh $conf->config_binary("logo_${template}.eps")
- or die "can't write temp file: $!\n";
- }else{
- print $lh $conf->config_binary('logo.eps')
- or die "can't write temp file: $!\n";
- }
- close $lh;
- $invoice_data{'logo_file'} = $lh->filename;
-
my $fh = new File::Temp( TEMPLATE => 'invoice.'. $self->invnum. '.XXXXXXXX',
DIR => $dir,
SUFFIX => '.tex',
close $fh;
$fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
- return ($1, $invoice_data{'logo_file'});
+ return $1;
}
sub print_ps {
my $self = shift;
- my ($file, $lfile) = $self->print_latex(@_);
+ my $file = $self->print_latex(@_);
my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
chdir($dir);
or die "can't open $file.ps: $! (error in LaTeX template?)\n";
unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex");
- unlink("$lfile");
my $ps = '';
while (<POSTSCRIPT>) {
sub print_pdf {
my $self = shift;
- my ($file, $lfile) = $self->print_latex(@_);
+ my $file = $self->print_latex(@_);
my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
chdir($dir);
or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex");
- unlink("$lfile");
my $pdf = '';
while (<PDF>) {
#'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
#'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
#'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
- my @tables = eval(join('\n',$conf->config('cust_main-skeleton_tables')));
+ my @tables = eval($conf->config_binary('cust_main-skeleton_tables'));
die $@ if $@;
_copy_skel( 'cust_main', #tablename
Accepts the following options: I<search>, the string to search for. The string
will be searched for as a customer number, phone number, name or company name,
as an exact, or, in some cases, a substring or fuzzy match (see the source code
-for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
-skip fuzzy matching when an exact match is found.
+for the exact heuristics used).
Any additional options are treated as an additional qualifier on the search
(i.e. I<agentnum>).
my @cust_main = ();
- my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
my $search = delete $options{'search'};
( my $alphanum_search = $search ) =~ s/\W//g;
#always do substring & fuzzy,
#getting complains searches are not returning enough
- unless ( @cust_main && $skip_fuzzy ) { #no exact match, trying substring/fuzzy
+ #unless ( @cust_main ) { #no exact match, trying substring/fuzzy
#still some false laziness w/ search/cust_main.cgi
FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
}
- }
+ #}
#eliminate duplicates
my %saw = ();
=item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
-Sends a templated email notification to the customer (see L<Text::Template>).
+Sends a templated email notification to the customer (see L<Text::Template).
OPTIONS is a hash and may include
my $cust_main = $svc->cust_svc->cust_pkg->cust_main;
- my $err_or_som = $self->prizm_command('CustomerIfService', 'getCustomers',
+ my $err_or_som = $self->prizm_command(CustomerIfService, 'getCustomers',
['import_id'],
[$cust_main->custnum],
['='],
$err_or_som = $self->prizm_command('NetworkIfService', 'addProvisionedElement',
$networkid,
$svc->mac_addr,
- $name, # we fix this below (bug in prizm?)
+ $name . " " . $svc->description,
$location,
$contact,
sprintf("%032X", $svc->authkey),
$svc->latitude,
$svc->longitude,
$svc->altitude,
- $name . " " . $svc->description,
+ $name,
$location,
$contact,
);
<LI><code>$username</code>
<LI><code>$_password</code>
<LI><code>$quoted_password</code> - unencrypted password, already quoted for the shell (do not add additional quotes).
- <LI><code>$crypt_password</code> - encrypted password. When used on the command line (rather than STDIN), it will be quoted for the shell already (do not add additional quotes).
- <LI><code>$ldap_password</code> - Password in LDAP/RFC2307 format (for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or "{MD5}5426824942db4253f87a1009fd5d2d4"). When used on the command line (rather than STDIN), it will be quoted for the shell already (do not add additional quotes).
+ <LI><code>$crypt_password</code> - encrypted password. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes).
<LI><code>$uid</code>
<LI><code>$gid</code>
- <LI><code>$finger</code> - GECOS. When used on the command line (rather than STDIN), it will be quoted for the shell already (do not add additional quotes).
- <LI><code>$first</code> - First name of GECOS. When used on the command line (rather than STDIN), it will be quoted for the shell already (do not add additional quotes).
- <LI><code>$last</code> - Last name of GECOS. When used on the command line (rather than STDIN), it will be quoted for the shell already (do not add additional quotes).
+ <LI><code>$finger</code> - GECOS. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes).
+ <LI><code>$first</code> - First name of GECOS. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes).
+ <LI><code>$last</code> - Last name of GECOS. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes).
<LI><code>$dir</code> - home directory
<LI><code>$shell</code>
<LI><code>$quota</code>
$quoted_password = shell_quote $_password;
$crypt_password = $svc_acct->crypt_password( $self->option('crypt') );
- $ldap_password = $svc_acct->ldap_password( $self->option('crypt') );
@radius_groups = $svc_acct->radius_groups;
$last = shell_quote $last;
$finger = shell_quote $finger;
$crypt_password = shell_quote $crypt_password;
- $ldap_password = shell_quote $ldap_password;
my $command_string = eval(qq("$command"));
$new_domain = $new->domain;
$new_crypt_password = $new->crypt_password( $self->option('crypt') );
- $new_ldap_password = $new->ldap_password( $self->option('crypt') );
@old_radius_groups = $old->radius_groups;
@new_radius_groups = $new->radius_groups;
$new_last = shell_quote $new_last;
$new_finger = shell_quote $new_finger;
$new_crypt_password = shell_quote $new_crypt_password;
- $new_ldap_password = shell_quote $new_ldap_password;
my $command_string = eval(qq("$command"));
+++ /dev/null
-package FS::part_pkg::base_delayed;
-
-use strict;
-use vars qw(@ISA %info);
-#use FS::Record qw(qsearch qsearchs);
-use FS::part_pkg::base_rate;
-
-@ISA = qw(FS::part_pkg::base_rate);
-
-%info = (
- 'name' => 'Free (or setup fee) for X days, then base rate'.
- ' (anniversary billing)',
- 'fields' => {
- 'setup_fee' => { 'name' => 'Setup fee for this package',
- 'default' => 0,
- },
- 'free_days' => { 'name' => 'Initial free days',
- 'default' => 0,
- },
- 'recur_fee' => { 'name' => 'Recurring base fee for this package',
- 'default' => 0,
- },
- 'recur_notify' => { 'name' => 'Number of days before recurring billing'.
- 'commences to notify customer. (0 means '.
- 'no warning)',
- 'default' => 0,
- },
- 'unused_credit' => { 'name' => 'Credit the customer for the unused portion'.
- ' of service at cancellation',
- 'type' => 'checkbox',
- },
- },
- 'fieldorder' => [ 'free_days', 'setup_fee', 'recur_fee', 'recur_notify',
- 'unused_credit'
- ],
- #'setup' => '\'my $d = $cust_pkg->bill || $time; $d += 86400 * \' + what.free_days.value + \'; $cust_pkg->bill($d); $cust_pkg_mod_flag=1; \' + what.setup_fee.value',
- #'recur' => 'what.recur_fee.value',
- 'weight' => 50,
-);
-
-sub calc_setup {
- my($self, $cust_pkg, $time ) = @_;
-
- my $d = $cust_pkg->bill || $time;
- $d += 86400 * $self->option('free_days');
- $cust_pkg->bill($d);
-
- $self->option('setup_fee');
-}
-
-1;
+++ /dev/null
-package FS::part_pkg::base_rate;
-
-use strict;
-use vars qw(@ISA %info);
-#use FS::Record qw(qsearch);
-use FS::part_pkg;
-
-@ISA = qw(FS::part_pkg);
-
-%info = (
- 'name' => 'Base rate (anniversary billing, Times units ordered)',
- 'fields' => {
- 'setup_fee' => { 'name' => 'Setup fee for this package',
- 'default' => 0,
- },
- 'recur_fee' => { 'name' => 'Recurring Base fee for this package',
- 'default' => 0,
- },
- 'unused_credit' => { 'name' => 'Credit the customer for the unused portion'.
- ' of service at cancellation',
- 'type' => 'checkbox',
- },
- 'externalid' => { 'name' => 'Optional External ID',
- 'default' => '',
- },
- },
- 'fieldorder' => [ 'setup_fee', 'recur_fee', 'unused_credit',
- 'externalid' ],
- 'weight' => 10,
-);
-
-sub calc_setup {
- my($self, $cust_pkg, $sdate, $details ) = @_;
-
- my $i = 0;
- my $count = $self->option( 'additional_count', 'quiet' ) || 0;
- while ($i < $count) {
- push @$details, $self->option( 'additional_info' . $i++ );
- }
-
- $self->option('setup_fee');
-}
-
-sub calc_recur {
- my($self, $cust_pkg) = @_;
- $self->reset_usage($cust_pkg);
- $self->base_recur($cust_pkg);
-}
-
-sub base_recur {
- my($self, $cust_pkg) = @_;
- my $units = $cust_pkg->option('units') ? $cust_pkg->option('units') : 1 ;
- # default to 1 if not found
- sprintf("%.2f",
- ($self->option('recur_fee') * $units )
- );
-}
-
-sub calc_remain {
- my ($self, $cust_pkg) = @_;
- my $time = time; #should be able to pass this in for credit calculation
- my $next_bill = $cust_pkg->getfield('bill') || 0;
- my $last_bill = $cust_pkg->last_bill || 0;
- return 0 if ! $self->base_recur
- || ! $self->option('unused_credit', 1)
- || ! $last_bill
- || ! $next_bill
- || $next_bill < $time;
-
- my %sec = (
- 'h' => 3600, # 60 * 60
- 'd' => 86400, # 60 * 60 * 24
- 'w' => 604800, # 60 * 60 * 24 * 7
- 'm' => 2629744, # 60 * 60 * 24 * 365.2422 / 12
- );
-
- $self->freq =~ /^(\d+)([hdwm]?)$/
- or die 'unparsable frequency: '. $self->freq;
- my $freq_sec = $1 * $sec{$2||'m'};
- return 0 unless $freq_sec;
-
- sprintf("%.2f", $self->base_recur * ( $next_bill - $time ) / $freq_sec );
-
-}
-
-sub is_free_options {
- qw( setup_fee recur_fee );
-}
-
-sub is_prepaid {
- 0; #no, we're postpaid
-}
-
-sub reset_usage {
- my($self, $cust_pkg) = @_;
- my %values = map { $_, $self->option($_) }
- grep { $self->option($_, 'hush') }
- qw(seconds upbytes downbytes totalbytes);
- $cust_pkg->set_usage(\%values);
-}
-
-1;
###
my( $to_or_from, $number );
- if ( $cdr->dst =~ /^(\+?1)?8([02-8])\1/ ) { #tollfree call
+ if ( $cdr->dst =~ /^(\+?1)?8[02-8]{2}/ ) { #tollfree call
$to_or_from = 'from';
$number = $cdr->src;
} else { #regular call
$username_noperiod $username_nounderscore $username_nodash
$username_uppercase $username_percent
$password_noampersand $password_noexclamation
+ $welcome_template $welcome_from
+ $welcome_subject $welcome_subject_template $welcome_mimetype
$warning_template $warning_from $warning_subject $warning_mimetype
$warning_cc
$smtpmachine
use Date::Format;
use Crypt::PasswdMD5 1.2;
use Data::Dumper;
-use Authen::Passphrase;
use FS::UID qw( datasrc );
use FS::Conf;
use FS::Record qw( qsearch qsearchs fields dbh dbdef );
$password_noampersand = $conf->exists('password-noexclamation');
$password_noexclamation = $conf->exists('password-noexclamation');
$dirhash = $conf->config('dirhash') || 0;
+ if ( $conf->exists('welcome_email') ) {
+ $welcome_template = new Text::Template (
+ TYPE => 'ARRAY',
+ SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
+ ) or warn "can't create welcome email template: $Text::Template::ERROR";
+ $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
+ $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
+ $welcome_subject_template = new Text::Template (
+ TYPE => 'STRING',
+ SOURCE => $welcome_subject,
+ ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
+ $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
+ } else {
+ $welcome_template = '';
+ $welcome_from = '';
+ $welcome_subject = '';
+ $welcome_mimetype = '';
+ }
if ( $conf->exists('warning_email') ) {
$warning_template = new Text::Template (
TYPE => 'ARRAY',
=item _password - generated if blank
-=item _password_encoding - plain, crypt, ldap (or empty for autodetection)
-
=item sec_phrase - security phrase
=item popnum - Point of presence (see L<FS::svc_acct_pop>)
if ( $cust_pkg ) {
my $cust_main = $cust_pkg->cust_main;
- my $agentnum = $cust_main->agentnum;
if ( $conf->exists('emailinvoiceautoalways')
|| $conf->exists('emailinvoiceauto')
}
#welcome email
- my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
- = ('','','','','','');
-
- if ( $conf->exists('welcome_email', $agentnum) ) {
- $welcome_template = new Text::Template (
- TYPE => 'ARRAY',
- SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
- ) or warn "can't create welcome email template: $Text::Template::ERROR";
- $welcome_from = $conf->config('welcome_email-from', $agentnum);
- # || 'your-isp-is-dum'
- $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
- || 'Welcome';
- $welcome_subject_template = new Text::Template (
- TYPE => 'STRING',
- SOURCE => $welcome_subject,
- ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
- $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
- || 'text/plain';
- }
+ my $to = '';
if ( $welcome_template && $cust_pkg ) {
my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
if ( $to ) {
|| $self->ut_snumbern('upbytes')
|| $self->ut_snumbern('downbytes')
|| $self->ut_snumbern('totalbytes')
- || $self->ut_enum( '_password_encoding',
- [ '', qw( plain crypt ldap ) ]
- )
;
return $error if $error;
unless ( $username_ampersand ) {
$recref->{username} =~ /\&/ and return gettext('illegal_username');
}
+ if ( $password_noampersand ) {
+ $recref->{_password} =~ /\&/ and return gettext('illegal_password');
+ }
+ if ( $password_noexclamation ) {
+ $recref->{_password} =~ /\!/ and return gettext('illegal_password');
+ }
unless ( $username_percent ) {
$recref->{username} =~ /\%/ and return gettext('illegal_username');
}
$recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
} else {
return "Illegal shell \`". $self->shell. "\'; ".
- "shells configuration value contains: @shells";
+ $conf->dir. "/shells contains: @shells";
}
} else {
$recref->{shell} = '/bin/sync';
$self->ut_textn($_);
}
- if ( $recref->{_password_encoding} eq 'ldap' ) {
-
- if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
- $recref->{_password} = uc($1).$2;
- } else {
- return 'Illegal (ldap-encoded) password: '. $recref->{_password};
- }
-
- } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
-
- if ( $recref->{_password} =~
- #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
- /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
- ) {
-
- $recref->{_password} = $1.$2;
-
- } else {
- return 'Illegal (crypt-encoded) password';
- }
-
- } elsif ( $recref->{_password_encoding} eq 'plain' ) {
-
- #generate a password if it is blank
- $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
- unless length( $recref->{_password} );
-
- if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
- $recref->{_password} = $1;
- } else {
- return gettext('illegal_password'). " $passwordmin-$passwordmax ".
- FS::Msgcat::_gettext('illegal_password_characters').
- ": ". $recref->{_password};
- }
-
- if ( $password_noampersand ) {
- $recref->{_password} =~ /\&/ and return gettext('illegal_password');
- }
- if ( $password_noexclamation ) {
- $recref->{_password} =~ /\!/ and return gettext('illegal_password');
- }
-
+ #generate a password if it is blank
+ $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
+ unless ( $recref->{_password} );
+
+ #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
+ if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
+ $recref->{_password} = $1.$3;
+ #uncomment this to encrypt password immediately upon entry, or run
+ #bin/crypt_pw in cron to give new users a window during which their
+ #password is available to techs, for faxing, etc. (also be aware of
+ #radius issues!)
+ #$recref->{password} = $1.
+ # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
+ #;
+ } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
+ $recref->{_password} = $1.$3;
+ } elsif ( $recref->{_password} eq '*' ) {
+ $recref->{_password} = '*';
+ } elsif ( $recref->{_password} eq '!' ) {
+ $recref->{_password} = '!';
+ } elsif ( $recref->{_password} eq '!!' ) {
+ $recref->{_password} = '!!';
} else {
-
- #carp "warning: _password_encoding unspecified\n";
-
- #generate a password if it is blank
- unless ( length( $recref->{_password} ) ) {
-
- $recref->{_password} =
- join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
- $recref->{_password_encoding} = 'plain';
-
- } else {
-
- #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
- if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
- $recref->{_password} = $1.$3;
- $recref->{_password_encoding} = 'plain';
- } elsif ( $recref->{_password} =~
- /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
- ) {
- $recref->{_password} = $1.$3;
- $recref->{_password_encoding} = 'crypt';
- } elsif ( $recref->{_password} eq '*' ) {
- $recref->{_password} = '*';
- $recref->{_password_encoding} = 'crypt';
- } elsif ( $recref->{_password} eq '!' ) {
- $recref->{_password_encoding} = 'crypt';
- $recref->{_password} = '!';
- } elsif ( $recref->{_password} eq '!!' ) {
- $recref->{_password} = '!!';
- $recref->{_password_encoding} = 'crypt';
- } else {
- #return "Illegal password";
- return gettext('illegal_password'). " $passwordmin-$passwordmax ".
- FS::Msgcat::_gettext('illegal_password_characters').
- ": ". $recref->{_password};
- }
-
- }
-
+ #return "Illegal password";
+ return gettext('illegal_password'). " $passwordmin-$passwordmax ".
+ FS::Msgcat::_gettext('illegal_password_characters').
+ ": ". $recref->{_password};
}
$self->SUPER::check;
-
}
=item _check_system
#self-service and pay up
( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
- if ( $self->_password_encoding eq 'ldap' ) {
-
- my $auth = from_rfc2307 Authen::Passphrase $self->_password;
- return $auth->match($check_password);
-
- } elsif ( $self->_password_encoding eq 'crypt' ) {
-
- my $auth = from_crypt Authen::Passphrase $self->_password;
- return $auth->match($check_password);
-
- } elsif ( $self->_password_encoding eq 'plain' ) {
-
- return $check_password eq $password;
-
+ #eventually should check a "password-encoding" field
+ if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
+ return 0;
+ } elsif ( length($password) < 13 ) { #plaintext
+ $check_password eq $password;
+ } elsif ( length($password) == 13 ) { #traditional DES crypt
+ crypt($check_password, $password) eq $password;
+ } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
+ unix_md5_crypt($check_password, $password) eq $password;
+ } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
+ warn "Can't check password: Blowfish encryption not yet supported, svcnum".
+ $self->svcnum. "\n";
+ 0;
} else {
-
- #XXX this could be replaced with Authen::Passphrase stuff
-
- if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
- return 0;
- } elsif ( length($password) < 13 ) { #plaintext
- $check_password eq $password;
- } elsif ( length($password) == 13 ) { #traditional DES crypt
- crypt($check_password, $password) eq $password;
- } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
- unix_md5_crypt($check_password, $password) eq $password;
- } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
- warn "Can't check password: Blowfish encryption not yet supported, ".
- "svcnum ". $self->svcnum. "\n";
- 0;
- } else {
- warn "Can't check password: Unrecognized encryption for svcnum ".
- $self->svcnum. "\n";
- 0;
- }
-
+ warn "Can't check password: Unrecognized encryption for svcnum ".
+ $self->svcnum. "\n";
+ 0;
}
}
sub crypt_password {
my $self = shift;
-
- if ( $self->_password_encoding eq 'ldap' ) {
-
- if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
- my $plain = $2;
-
- #XXX this could be replaced with Authen::Passphrase stuff
-
- my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
- if ( $encryption eq 'crypt' ) {
- crypt(
- $self->_password,
- $saltset[int(rand(64))].$saltset[int(rand(64))]
- );
- } elsif ( $encryption eq 'md5' ) {
- unix_md5_crypt( $self->_password );
- } elsif ( $encryption eq 'blowfish' ) {
- croak "unknown encryption method $encryption";
- } else {
- croak "unknown encryption method $encryption";
- }
-
- } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
- $1;
- }
-
- } elsif ( $self->_password_encoding eq 'crypt' ) {
-
- return $self->_password;
-
- } elsif ( $self->_password_encoding eq 'plain' ) {
-
- #XXX this could be replaced with Authen::Passphrase stuff
-
+ #eventually should check a "password-encoding" field
+ if ( length($self->_password) == 13
+ || $self->_password =~ /^\$(1|2a?)\$/
+ || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
+ )
+ {
+ $self->_password;
+ } else {
my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
if ( $encryption eq 'crypt' ) {
crypt(
} else {
croak "unknown encryption method $encryption";
}
-
- } else {
-
- if ( length($self->_password) == 13
- || $self->_password =~ /^\$(1|2a?)\$/
- || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
- )
- {
- $self->_password;
- } else {
-
- #XXX this could be replaced with Authen::Passphrase stuff
-
- my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
- if ( $encryption eq 'crypt' ) {
- crypt(
- $self->_password,
- $saltset[int(rand(64))].$saltset[int(rand(64))]
- );
- } elsif ( $encryption eq 'md5' ) {
- unix_md5_crypt( $self->_password );
- } elsif ( $encryption eq 'blowfish' ) {
- croak "unknown encryption method $encryption";
- } else {
- croak "unknown encryption method $encryption";
- }
-
- }
-
}
-
}
=item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
-describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
-"{MD5}5426824942db4253f87a1009fd5d2d4".
+describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
+"{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
to work the same as the B</crypt_password> method.
sub ldap_password {
my $self = shift;
#eventually should check a "password-encoding" field
-
- if ( $self->_password_encoding eq 'ldap' ) {
-
- return $self->_password;
-
- } elsif ( $self->_password_encoding eq 'crypt' ) {
-
- if ( length($self->_password) == 13 ) { #crypt
- return '{CRYPT}'. $self->_password;
- } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
- return '{MD5}'. $1;
- #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
- # die "Blowfish encryption not supported in this context, svcnum ".
- # $self->svcnum. "\n";
- } else {
- warn "encryption method not (yet?) supported in LDAP context";
- return '{CRYPT}*'; #unsupported, should not auth
- }
-
- } elsif ( $self->_password_encoding eq 'plain' ) {
-
+ if ( length($self->_password) == 13 ) { #crypt
+ return '{CRYPT}'. $self->_password;
+ } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
+ return '{MD5}'. $1;
+ } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
+ die "Blowfish encryption not supported in this context, svcnum ".
+ $self->svcnum. "\n";
+ } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
+ return '{SSHA}'. $1;
+ } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
+ return '{NS-MTA-MD5}'. $1;
+ } else { #plaintext
return '{PLAIN}'. $self->_password;
-
- #return '{CLEARTEXT}'. $self->_password; #?
-
- } else {
-
- if ( length($self->_password) == 13 ) { #crypt
- return '{CRYPT}'. $self->_password;
- } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
- return '{MD5}'. $1;
- } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
- warn "Blowfish encryption not supported in this context, svcnum ".
- $self->svcnum. "\n";
- return '{CRYPT}*';
-
- #are these two necessary anymore?
- } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
- return '{SSHA}'. $1;
- } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
- return '{NS-MTA-MD5}'. $1;
-
- } else { #plaintext
- return '{PLAIN}'. $self->_password;
-
- #return '{CLEARTEXT}'. $self->_password; #?
-
- #XXX this could be replaced with Authen::Passphrase stuff if it gets used
- #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
- #if ( $encryption eq 'crypt' ) {
- # return '{CRYPT}'. crypt(
- # $self->_password,
- # $saltset[int(rand(64))].$saltset[int(rand(64))]
- # );
- #} elsif ( $encryption eq 'md5' ) {
- # unix_md5_crypt( $self->_password );
- #} elsif ( $encryption eq 'blowfish' ) {
- # croak "unknown encryption method $encryption";
- #} else {
- # croak "unknown encryption method $encryption";
- #}
- }
-
+ #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
+ #if ( $encryption eq 'crypt' ) {
+ # return '{CRYPT}'. crypt(
+ # $self->_password,
+ # $saltset[int(rand(64))].$saltset[int(rand(64))]
+ # );
+ #} elsif ( $encryption eq 'md5' ) {
+ # unix_md5_crypt( $self->_password );
+ #} elsif ( $encryption eq 'blowfish' ) {
+ # croak "unknown encryption method $encryption";
+ #} else {
+ # croak "unknown encryption method $encryption";
+ #}
}
-
}
=item domain_slash_username
|| $self->ut_hexn('auth_key')
|| $self->ut_coordn('latitude', -90, 90)
|| $self->ut_coordn('longitude', -180, 180)
- || $self->ut_sfloatn('altitude')
+ || $self->ut_floatn('altitude')
|| $self->ut_textn('vlan_profile')
;
return $error if $error;
FS/part_pkg/subscription.pm
FS/part_pkg/voip_sqlradacct.pm
FS/part_pkg/voip_cdr.pm
-FS/part_pkg/base_rate.pm
-FS/part_pkg/base_delayed.pm
FS/part_pop_local.pm
FS/part_referral.pm
FS/part_svc.pm
t/reason_type.t
FS/cust_pkg_option.pm
t/cust_pkg_option.t
-FS/conf.pm
-t/conf.t
+++ /dev/null
-#!/usr/bin/perl -Tw
-
-use strict;
-use vars qw( $user $block @blocks );
-use FS::UID qw(adminsuidsetup);
-use FS::Record qw(qsearch);
-use FS::addr_block;
-use FS::svc_broadband;
-
-$user = shift or die &usage;
-&adminsuidsetup( $user );
-
-@blocks = qsearch('addr_block', {} );
-die "No address blocks" unless (scalar(@blocks) > 0);
-
-foreach $block (@blocks) {
- my @devices = qsearch('svc_broadband', { 'blocknum' => $block->blocknum } );
- if (@devices) {
- print "Skipping block " . $block->ip_gateway . " / " . $block->ip_netmask;
- print "\n";
- }else{
- print "Deleting block " . $block->ip_gateway . " / " . $block->ip_netmask;
- print "\n";
- $block->delete;
- }
-}
-
-
-sub usage {
- "Usage:\n freeside-delete-addr_blocks user \n";
-}
+++ /dev/null
-#!/usr/bin/perl -Tw
-
-use strict;
-use vars qw($opt_u $opt_f $opt_v);
-use Getopt::Std;
-use IO::File;
-use FS::UID qw(adminsuidsetup checkeuid dbh);
-use FS::CurrentUser;
-use FS::Record qw(qsearch);
-
-
-die "Not running uid freeside!" unless checkeuid();
-
-getopts("u:vf");
-my $dir = shift or die &usage;
-
-$FS::CurrentUser::upgrade_hack = 1;
-adminsuidsetup $opt_u; #$user;
-
-$|=1;
-
-my $conf = new FS::Conf;
-if (!scalar(qsearch('conf', {})) || $opt_f) {
-
- foreach my $item ( $conf->config_items() ) {
- insert_config_item($item,$dir);
- }
-
- # ugly pseudo false laziness with Conf.pm
- foreach my $item ( map { my $basename = basename($_);
- $basename =~ /^(.*)$/;
- $basename = $1;
- new FS::ConfItem {
- 'key' => $basename,
- 'type' => '',
- }
- } glob($dir. '/invoice_template_*'),
- glob($dir. '/invoice_html_*'),
- glob($dir. '/invoice_htmlnotes_*'),
- glob($dir. '/invoice_latex_*'),
- glob($dir. '/invoice_latexnotes_*')
- ) {
-
- insert_config_item($item,$dir);
-
- }
-
- foreach my $item ( map { my $basename = basename($_);
- $basename =~ /^(.*)$/;
- $basename = $1;
- new FS::ConfItem {
- 'key' => $basename,
- 'type' => 'binary',
- }
- } glob($dir. '/logo_*.png'),
- glob($dir. '/logo_*.eps')
- ) {
-
- insert_config_item($item,$dir);
-
- }
-
-}
-
-warn "Freeside database initialized - committing transaction\n" if $opt_v;
-
-dbh->commit or die dbh->errstr;
-dbh->disconnect or die dbh->errstr;
-
-warn "Configuration initialization committed successfully\n" if $opt_v;
-
-sub insert_config_item {
- local $/;
- my ($item,$dir) = @_;
- my $key = $item->key;
- if (-e "$dir/$key") {
- warn "Inserting $key\n" if $opt_v;
- my $value = readline(new IO::File "$dir/$key");
- if ($item->type eq 'binary'){
- $conf->set_binary($key, $value);
- }else{
- $conf->set($key, $value);
- }
- }
-}
-
-sub usage {
- die "Usage:\n freeside-init-config directory [ -v ] [ -f ]\n"
- # [ -u user ] for devel/multi-db installs
-}
-
-1;
use FS::ClientAPI;
use FS::Conf;
-use FS::cust_svc;
+use FS::cust_bill;
+use FS::cust_pkg;
$FREESIDE_LOG = "%%%FREESIDE_LOG%%%";
$FREESIDE_LOCK = "%%%FREESIDE_LOCK%%%";
daemonize2();
my $conf = new FS::Conf;
-if ( $conf->exists('selfservice-ignore_quantity') ) {
- $FS::cust_svc::ignore_quantity = 1;
- $FS::cust_svc::ignore_quantity = 1; #now it is used twice.
-}
my $clientd = "/usr/local/sbin/freeside-selfservice-clientd"; #better name?
# map { lc($FS::raddb::attrib{$_}) => $_ } keys %FS::raddb::attrib;
getopts("u:vd:");
-my $config_dir = shift || 'conf' ;
-$config_dir =~ /^([\w.:=]+)$/
- or die "unacceptable configuration directory name";
-$config_dir = $1;
+#my $user = shift or die &usage;
-getsecrets($opt_u);
+getsecrets($opt_u); #$user);
#needs to match FS::Record
my($dbdef_file) = "%%%FREESIDE_CONF%%%/dbdef.". datasrc;
###
$FS::CurrentUser::upgrade_hack = 1;
-$FS::UID::callback_hack = 1;
my $dbh = adminsuidsetup $opt_u; #$user;
-$FS::UID::callback_hack = 0;
#create tables
$|=1;
delete $FS::Schema::dbdef_cache{$dbdef_file}; #force an actual reload
reload_dbdef($dbdef_file);
-warn "Freeside schema initialized - commiting transaction\n" if $opt_v;
-
-$dbh->commit or die $dbh->errstr;
-$dbh->disconnect or die $dbh->errstr;
-
-warn "Database schema committed successfully\n" if $opt_v;
-
-my $init_config = "freeside-init-config";
-$init_config .= " -v" if $opt_v;
-$init_config .= " -u $opt_u" if $opt_u;
-$init_config .= " $config_dir";
-system "$init_config" ;
-
-$dbh = adminsuidsetup $opt_u;
create_initial_data('domain' => $opt_d);
warn "Freeside database initialized - commiting transaction\n" if $opt_v;
}
sub usage {
- die "Usage:\n freeside-setup -d domain.name [ -v ] [ config/dir ]\n"
+ die "Usage:\n freeside-setup -d domain.name [ -v ]\n"
# [ -u user ] for devel/multi-db installs
}
$dbh->disconnect or die $dbh->errstr;
-unless ( $DRY_RUN ) {
- my $init_config = "freeside-init-config -u $user ";
- $init_config .= "%%%FREESIDE_CONF%%%/conf.". datasrc;
- system "$init_config" ;
-}
-
###
sub dbdef_create { # reverse engineer the schema from the DB and save to file
+++ /dev/null
-BEGIN { $| = 1; print "1..1\n" }
-END {print "not ok 1\n" unless $loaded;}
-use FS::conf;
-$loaded=1;
-print "ok 1\n";
+++ /dev/null
-BEGIN { $| = 1; print "1..1\n" }
-END {print "not ok 1\n" unless $loaded;}
-use FS::cust_pkg_option;
-$loaded=1;
-print "ok 1\n";
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use Text::CSV_XS;
-use FS::UID qw(adminsuidsetup);
-use FS::svc_acct_pop;
-
-my @fields = qw( ac loc state city exch );
-my $fixup = sub {
- my $hash = shift;
- $hash->{ac} =~ /^\s*(\d{3})\s*$/;
- $hash->{ac} = $1;
- $hash->{loc} =~ /^\s*(\d{3})(\d{4})\s*$/;
- $hash->{exch} = $1;
- $hash->{loc} = $2;
- $hash->{state} =~ /^\s*(\S{0,2})\s*$/;
- $hash->{state} = $1;
- $hash->{city} =~ /^\s*(.*?)\s*$/;
- $hash->{city} = $1;
-
- };
-
-my $user = shift or usage();
-adminsuidsetup $user;
-
-my $file = shift or usage();
-my $csv = new Text::CSV_XS;
-
-open(FH, $file) or die "cannot open $file: $!";
-
-sub usage {
- die "Usage:\n\n svc_acct_pop.import user popfile.csv\n\n";
-}
-
-###
-
-my $line;
-while ( defined($line=<FH>) ) {
- chomp $line;
-
- $line &= "\177" x length($line); # i hope this isn't really necessary
- $csv->parse($line)
- or die "cannot parse: " . $csv->error_input();
-
- my @values = $csv->fields();
- my %hash;
- foreach my $field (@fields) {
- $hash{$field} = shift @values;
- }
-
- &{$fixup}(\%hash);
-
- my $svc_acct_pop = new FS::svc_acct_pop { %hash };
-
- #my $error = $svc_acct_pop->check;
- my $error = $svc_acct_pop->insert;
- die $error if $error;
-
-}
\returninset\r
\makebox{\r
\begin{tabular}{ll}\r
- \includegraphics{[@-- $logo_file --@]} &\r
+ \includegraphics{[@-- $conf_dir --@]/logo.eps} &\r
\begin{minipage}[b]{5.5cm}\r
[@-- $returnaddress --@]\r
\end{minipage}\r
}\r
}\r
{ % ... pages\r
- %\includegraphics{[@-- $logo_file --@]} % Uncomment if you want the logo on all pages.\r
+ %\includegraphics{[@-- $conf_dir --@]/logo.eps} % Uncomment if you want the logo on all pages.\r
}\r
}\r
\r
unless ( $error ) {
my $rv = new_customer( {
- ( map { $_ => scalar($cgi->param($_)) }
- qw( last first ss company
- address1 address2 city county state zip country
- daytime night fax
-
- ship_last ship_first ship_company
- ship_address1 ship_address2 ship_city ship_county ship_state
- ship_zip ship_country
- ship_daytime ship_night ship_fax
-
- payby payinfo paycvv paydate payname invoicing_list
- referral_custnum promo_code reg_code
- pkgpart username sec_phrase _password popnum refnum
- agentnum
- ),
- grep { /^snarf_/ } $cgi->param
- ),
- 'payip' => $cgi->remote_host(),
+ map { $_ => scalar($cgi->param($_)) }
+ qw( last first ss company
+ address1 address2 city county state zip country
+ daytime night fax
+
+ ship_last ship_first ship_company
+ ship_address1 ship_address2 ship_city ship_county ship_state
+ ship_zip ship_country
+ ship_daytime ship_night ship_fax
+
+ payby payinfo paycvv paydate payname invoicing_list
+ referral_custnum promo_code reg_code
+ pkgpart username sec_phrase _password popnum refnum
+ agentnum
+ ),
+ grep { /^snarf_/ } $cgi->param
} );
$error = $rv->{'error'};
}
use Chart::LinesPoints;
use Chart::Mountain;
use Color::Scheme;
- use HTML::Widgets::SelectLayers 0.07;
+ use HTML::Widgets::SelectLayers 0.06;
+ #use HTML::Widgets::SelectLayers 0.07; # after 1.7.2
use Locale::Country;
use FS;
use FS::UID qw(cgisuidsetup dbh getotaker datasrc driver_name);
+++ /dev/null
-%
-%
-%my $conf=new FS::Conf;
-%
-%http_header('Content-Type' => 'application/x-unknown' );
-%
-%die "No configuration variable specified (bad URL)!" # umm
-% unless $cgi->keywords;
-%my($query) = $cgi->keywords;
-%$query =~ /^([\w -\)+-\/@;:?=[\]]+)$/;
-%my $name = $1;
-%
-%http_header('Content-Disposition' => "attachment; filename=$name" );
-% print $conf->config_binary($name);
-<%init>
-die "access denied"
- unless $FS::CurrentUser::CurrentUser->access_right('Configuration');
-</%init>
<%init>
+
die "access denied\n"
unless $FS::CurrentUser::CurrentUser->access_right('Configuration');
} else {
$conf->delete($i->key);
}
- } elsif ( $type eq 'binary' ) {
- if ( defined($cgi->param($i->key. $n)) && $cgi->param($i->key. $n) ) {
- my $fh = $cgi->upload($i->key. $n);
- if (defined($fh)) {
- local $/;
- $conf->set_binary($i->key, <$fh>);
- }
- }else{
- warn "Condition failed for " . $i->key;
- }
} elsif ( $type eq 'checkbox' ) {
# if ( defined($cgi->param($i->key. $n)) && $cgi->param($i->key. $n) ) {
if ( defined $cgi->param($i->key. $n) ) {
$conf->touch($_) foreach @touch;
$conf->delete($_) foreach @delete;
}
+
</%init>
<% $cgi->redirect("config-view.cgi") %>
<tr>
<td><font color="#ff0000">no type</font></td>
</tr>
-% } elsif ( $type eq 'binary' ) {
-
- <tr>
- <% $conf->exists($i->key)
- ? qq!<a href="config-download.cgi?!. $i->key. qq!">download</a>!
- : 'empty'
- %>
- </tr>
% } elsif ( $type eq 'textarea'
% || $type eq 'editlist'
% || $type eq 'selectmultiple' ) {
% my $conf = new FS::Conf; my @config_items = $conf->config_items;
-<form name="OneTrueForm" action="config-process.cgi" METHOD="POST" enctype="multipart/form-data" onSubmit="SafeOnsubmit()">
+<form name="OneTrueForm" action="config-process.cgi" METHOD="POST" onSubmit="SafeOnsubmit()">
% foreach my $section ( qw(required billing username password UI session
% shell BIND
% ),
<font color="#ff0000">no type</font>
-% } elsif ( $type eq 'binary' ) {
-
-
- Filename <input type="file" name="<% $i->key. $n %>">
% } elsif ( $type eq 'textarea' ) {
</TD><TD VALIGN="top">
-Reseller information
-<% ntable("#cccccc", 2) %>
- <TR>
- <TD ALIGN="right"><% 'Agent Types' %></TD>
- <TD>
- <% include( '/elements/select-table.html',
- 'element_name' => 'agent_type',
- 'table' => 'agent_type',
- 'name_col' => 'atype',
- 'value' => \@agent_type,
- 'empty_label' => '(none)',
- 'element_etc' => 'multiple size="10"',
- )
- %>
- </TD>
- </TR>
-</TABLE>
+%#Reseller information # after 1.7.2
+%#<% ntable("#cccccc", 2) %>
+%# <TR>
+%# <TD ALIGN="right"><% 'Agent Types' %></TD>
+%# <TD>
+%# <% include( '/elements/select-table.html',
+%# 'element_name' => 'agent_type',
+%# 'table' => 'agent_type',
+%# 'name_col' => 'atype',
+%# 'value' => \@agent_type,
+%# 'empty_label' => '(none)',
+%# 'element_etc' => 'multiple size="10"',
+%# )
+%# %>
+%# </TD>
+%# </TR>
+%#</TABLE>
</TD></TR></TABLE>
%
%
%#} else {
%# push @fixups, 'taxclass'; #hidden
%#}
-%my @form_elements = ( 'classnum', 'taxclass', 'agent_type' );
+%my @form_elements = ( 'classnum', 'taxclass' );
+%# copying non-existant elements is probably harmless, but after 1.7.2
+%#my @form_elements = ( 'classnum', 'taxclass', 'agent_type' );
%
%my @form_radio = ();
%if ( dbdef->table('pkg_svc')->column('primary_svc') ) {
% ( exists($plandata{$field})
% ? $plandata{$field}
% : $href->{$field}{'default'} ).
-% qq!">!;
+% qq!" onChange="fchanged(this)">!; #after 1.7.2
% } elsif ( $href->{$field}{'type'} eq 'checkbox' ) {
% $html .= qq!<INPUT TYPE="checkbox" NAME="$field" VALUE=1 !.
% ( exists($plandata{$field}) && $plandata{$field}
% $html .= '<SELECT';
% $html .= ' MULTIPLE'
% if $href->{$field}{'type'} eq 'select_multiple';
-% $html .= qq! NAME="$field">!;
+% $html .= qq! NAME="$field" onChange="fchanged(this)">!; # after 1.7.2
%
% if ( $href->{$field}{'select_table'} ) {
% foreach my $record (
%
% $html .= '<INPUT TYPE="submit" VALUE="'.
% ( $hashref->{pkgpart} ? "Apply changes" : "Add package" ).
-% '">';
+% '" onClick="fchanged(this)">'; #after 1.7.2
%
% $html;
%
% $pkgpart = $new->pkgpart;
%}
%
-%unless ($error) {
+%unless (1 || $error) { # after 1.7.2
% my $error = $new->process_m2m(
% 'link_table' => 'type_pkgs',
% 'target_table' => 'agent_type',
tie my %tools_importing, 'Tie::IxHash',
'Import customers from CSV file' => [ $fsurl.'misc/cust_main-import.cgi', '' ],
- 'Import customer notes from CSV file' => [ $fsurl.'misc/cust_main_note-import.html', '' ],
'Import one-time charges from CSV file' => [ $fsurl.'misc/cust_main-import_charges.cgi', '' ],
'Import Call Detail Records (CDRs) from CSV file' => [ $fsurl.'misc/cdr-import.html', '' ],
;
+%
+% my( $number, %opt ) = @_;
+% my $conf = new FS::Conf;
+% ( my $snumber = $number ) =~ s/\D//g;
+%
+
<SCRIPT TYPE="text/javascript" SRC="<%$fsurl%>elements/overlibmws.js"></SCRIPT>
<SCRIPT TYPE="text/javascript" SRC="<%$fsurl%>elements/overlibmws_iframe.js"></SCRIPT>
<SCRIPT TYPE="text/javascript" SRC="<%$fsurl%>elements/overlibmws_draggable.js"></SCRIPT>
<SCRIPT TYPE="text/javascript" SRC="<%$fsurl%>elements/iframecontentmws.js"></SCRIPT>
-
% if ( length($number) ) {
<% $number %>
+% if ( $opt{'callable'} && $conf->config('vonage-username') ) {
-% if ( $opt{'callable'} && $curuser->option('vonage-username') ) {
-
- <A HREF="javascript:void(0);" onClick="overlib( OLiframeContent('https://secure.click2callu.com/tpcc/makecall?username=<% uri_escape($curuser->option('vonage-username')) %>&password=<% uri_escape($curuser->option('vonage-password')) %>&fromnumber=<% uri_escape($curuser->option('vonage-fromnumber')) %>&tonumber=1<% $snumber %>', 240, 64, 'call_popup'), CAPTION, 'Initiating call', STICKY, AUTOSTATUSCAP, CLOSECLICK, DRAGGABLE, WIDTH, 240, HEIGHT, 64 ); return false;" TITLE="Call this number"><IMG SRC="<%$fsurl%>images/red_telephone_mimooh_01.png" BORDER=0 ALT="Call this number"></A>
-
-% }
-%
+ <A HREF="javascript:void(0);" onClick="overlib( OLiframeContent('https://secure.click2callu.com/tpcc/makecall?username=<% $conf->config('vonage-username') %>&password=<% $conf->config('vonage-password') %>&fromnumber=<% $conf->config('vonage-fromnumber')%>&tonumber=1<% $snumber %>', 240, 64, 'call_popup'), CAPTION, 'Initiating call', STICKY, AUTOSTATUSCAP, CLOSECLICK, DRAGGABLE, WIDTH, 240, HEIGHT, 64 ); return false;" TITLE="Call this number"><IMG SRC="<%$fsurl%>images/red_telephone_mimooh_01.png" BORDER=0 ALT="Call this number"></A>
+% }
% } else {
-
% }
-<%init>
-
-my( $number, %opt ) = @_;
-( my $snumber = $number ) =~ s/\D//g;
-
-my $curuser = $FS::CurrentUser::CurrentUser;
-
-( my $vonage_number = $curuser->option('vonage-fromnumber') ) =~ s/\D//g;
-$vonage_number =~ /^1/ or $vonage_number = "1$vonage_number";
-</%init>
Change password (leave blank for no change)
<% ntable("#cccccc",2) %>
- <TR>
- <TH ALIGN="right">Current password: </TH>
- <TD><INPUT TYPE="password" NAME="_password"></TD>
- </TR>
+<TR>
+ <TD ALIGN="right">Current password: </TD>
+ <TD><INPUT TYPE="password" NAME="_password"></TD>
+</TR>
- <TR>
- <TH ALIGN="right">New password: </TH>
- <TD><INPUT TYPE="password" NAME="new_password"></TD>
- </TR>
+<TR>
+ <TD ALIGN="right">New password: </TD>
+ <TD><INPUT TYPE="password" NAME="new_password"></TD>
+</TR>
- <TR>
- <TH ALIGN="right">Re-enter new password: </TH>
- <TD><INPUT TYPE="password" NAME="new_password2"></TD>
- </TR>
+<TR>
+ <TD ALIGN="right">Re-enter new password: </TD>
+ <TD><INPUT TYPE="password" NAME="new_password2"></TD>
+</TR>
</TABLE>
<BR>
-
Interface
<% ntable("#cccccc",2) %>
- <TR>
- <TH>Menu location: </TH>
- <TD>
- <INPUT TYPE="radio" NAME="menu_position" VALUE="left" onClick="document.images['menu_example'].src='../images/menu-left-example.png';" <% $menu_position eq 'left' ? ' CHECKED' : ''%>> Left<BR>
- <INPUT TYPE="radio" NAME="menu_position" VALUE="top"onClick="document.images['menu_example'].src='../images/menu-top-example.png';" <% $menu_position eq 'top' ? ' CHECKED' : ''%>> Top <BR>
- </TD>
-
<TD><IMG NAME="menu_example" SRC="../images/menu-<% $menu_position %>-example.png"></TD>
- </TR>
+<TR>
+ <TD>Menu location: </TD>
+ <TD>
+ <INPUT TYPE="radio" NAME="menu_position" VALUE="left" onClick="document.images['menu_example'].src='../images/menu-left-example.png';" <% $menu_position eq 'left' ? ' CHECKED' : ''%>> Left<BR>
+ <INPUT TYPE="radio" NAME="menu_position" VALUE="top"onClick="document.images['menu_example'].src='../images/menu-top-example.png';" <% $menu_position eq 'top' ? ' CHECKED' : ''%>> Top <BR>
+ </TD>
+ <TD><IMG NAME="menu_example" SRC="../images/menu-<% $menu_position %>-example.png"></TD>
+</TR>
</TABLE>
<BR>
-
-Vonage integration (see <a href="https://secure.click2callu.com/">Click2Call</a>)
-<% ntable("#cccccc",2) %>
-
- <TR>
- <TH ALIGN="right">Vonage phone number</TH>
- <TD><INPUT TYPE="text" NAME="vonage-fromnumber"></TD>
- </TR>
-
- <TR>
- <TH ALIGN="right">Vonage username</TH>
- <TD><INPUT TYPE="text" NAME="vonage-username"></TD>
- </TR>
-
- <TR>
- <TH ALIGN="right">Vonage password</TH>
- <TD><INPUT TYPE="password" NAME="vonage-password"></TD>
- </TR>
-
-</TABLE>
-<BR>
-
-
% foreach my $prop (qw( height width availHeight availWidth colorDepth )) {
<INPUT TYPE="hidden" NAME="<% $prop %>" VALUE="">
<SCRIPT TYPE="text/javascript">
<TABLE>
<% include( '/elements/tr-select-agent.html',
- $cgi->param('agentnum') ? $cgi->param('agentnum') : '',
+ $cgi->param('agentnum'),
'label' => 'Invoices for agent: ',
)
%>
--- /dev/null
+1.22 Wed Mar 26 22:33:44 EST 2003
+ - Win32 compile fix for snprintf [Joe Spears]
+ - Fix memory allocation problem in bytea escaping [Barrie Slaymaker]
+ - Add utf8 support [Dominic Mitchell <dom@semantico.com>]
+ - Transform Perl arrays into PostgreSQL arrays [Alexey Slynko]
+ - Fix for foreign_key_info() [Keith Keller]
+ - Fix PG_TEXT parameter binding
+ - Doc cleanups [turnstep]
+ - Fix warning from func($table, 'table_attributes') [turnstep]
+ - Added suppport for schemas [turnstep]
+ - Fix binary to a bytea field conversion [Chris Dunlop <chris@onthe.net.au>]
+1.21 Sun Jan 12 21:00:44 EST 2003
+ - System tables no longer returned by tables(). [Dave Rolsky]
+ - Fix table_attributes to handle removal of pg_relcheck in 7.3,
+ from Ian Barwick <barwick@gmx.net>
+ - Properly reset transaction status after failed transaction when
+ autocommit is off. Properly report transaction failure message.
+ Kai <kai@xs4all.nl>
+ - New pg_bool_tf database handle that when set to true booleans are
+ returned as 't'/'f' rather than 1/0.
+
+1.20 Wed Nov 27 16:19:26 2002
+ - Maintenance transferred to GBorg,
+ http://gborg.postgresql.org/project/dbdpg/projdisplay.php. Incremented
+ version number to reflect new management. [Bruce Momjian]
+ - README cleaned up. [Bruce Momjian]
+ - Added t/15funct.t, a series of tests that determine if the meta data
+ is working. [Thomas Lowery]
+ - Added implementations of column_info() and table_info(), and
+ primary_key_info(). [Thomas Lowery]
+ - The POD formatting was cleaned up. [David Wheeler]
+ - The preparser was updated to better handle escaped characters. [Rudy
+ Lippan]
+ - Removed redundant use of strlen() in pg_error() (Jason E. Stewart).
+ - Test suite cleaned up, converted to use Test::More, and updated to use
+ standard DBI environment variables for connecting to a test database.
+ [Jason E. Stewart]
+ - Added eg/lotest.pl as a demonstration of using large objects in buffers
+ rather than files. Contributed by Garth Webb.
+ - Added LISTEN/NOTIFY functionality. Congributed by Alex Pilosov.
+ - Added constants for common PostgreSQL data types, plus simple tests to
+ make sure that they work. These are exportable via "use DBD::Pg
+ qw(:pg_types);". [David Wheeler]
+ - Deprecatated the undocumented (and invalid) use of SQL_BINARY in
+ bind_param() and documented the correct approach: "bind_param($num,
+ $val { pg_type => PG_BYTEA });". Use of SQL_BINARY in bind_param() will
+ now issue a warning if $h->{Warn} is true. [David Wheeler]
+ - Removed invalid (and broken) support for SQL_BINARY in quote(). [David
+ Wheeler]
+ - Added App::Info::RDBMS::PostgreSQL to the distribution (but it won't
+ be installed) to help Makefile.PL find the PostgreSQL include and
+ library files. [David Wheeler]
+ - Fixed compile-time warnings. [David Wheeler and Jason E. Stewart]
+
+2002-04-27 Jeffrey W. Baker <jwbaker@acm.org>
+
+ - dbdimp.c: Add default at end of switch statement for pg_type attrib.
+ - t/13pgtype.t: test for above.
+
+2002-04-09 Jeffrey W. Baker <jwbaker@acm.org>
+
+ - Pg.pm, dbdimp.c: Applied patch from
+ Thomas A. Lowery <tlowery@stlowery.net> concerning metadata
+ in table_info and so forth.
+
+2002-03-06 Jeffrey W. Baker <jwbaker@acm.org>
+ - Pg.pm (quote): Applied patch from David Wheeler <david@wheeler.net>
+ to simplfiy and speed up quoting.
+ - t/11quoting.t: Tests for above patch.
+ - t/12placeholders.t: Tests for placeholder parsing in quoted strings.
+
+2002-03-06 Jeffrey W. Baker
+ - Version 1.10 uploaded to CPAN.
+
+1.01 Jun 27, 2001
+ - fixed core dump when trying to use a BYTEA value with
+ a byte outside 0..127 Alex Pilosov <alex@pilosoft.com>
+
+1.00 May 27, 2001
+ - Fetching all records now resets Active flag as it should.
+
+0.99 May 24, 2001
+ - fix the segmentation fault in pg_error.
+
+0.98 Apr 25, 2001
+ - bug-fix for core-dump after any failed function call.
+ - applied patch from Alex Pilosov <alex@pilosoft.com>
+ which adds support for the datatype bytea
+
+0.97 Apr 20, 2001
+ - fix bug in connect method, which erroneously set the userid
+ and the password to the environment variables DBI_USER and
+ DBI_PASS.
+ - applied patch from Jan-Pieter Cornet <john@pc.xs4all.nl>,
+ which removed the special handling of a backslash when
+ used for octal presentation. Now a backslash always will
+ be escaped.
+
+0.96 Apr 09, 2001
+ - remove memory-leak in ping function, bug-fix
+ from Doug Perham <dperham@wgate.com>
+ - correct the recognition of primary keys in
+ table_attributes(). Patch from Brian Powell
+ <brian@nicklebys.com>.
+ - applied patch from David D. Kilzer <ddkilzer@lubricants-oil.com>
+ which fixes a segmentation fault in DBD::pg::blob_read() when
+ reading LOBs that required perl to reallocate space for the
+ variable holding the scalar value
+ - updated test.pl to create a test blob larger than 256 bytes
+ (now 128 Kbytes)
+ - apply patch from Tom Lane, which fixes a seg-fault when
+ inserting large amounts of text.
+ - apply patch from Peter Haworth pmh@edison.ioppublishing.com,
+ which removes the newlines from the error messages and which
+ quotes date placeholders.
+
+0.95 Jul 10, 2000
+ - add Win32 port from Bob Kline <bkline@rksystems.com>.
+
+0.94 Jul 07, 2000
+ - applied patch from Rudy Lippan <almighty@randomc.com>
+ which fixes a memory-leak with failed connections.
+ - applied patch from Hein Roehrig <hein@acm.org>
+ which fixes a bug with escaping a backslash except for
+ octal presentation
+ - applied patch from Francis J. Lacoste <francis.lacoste@iNsu.COM
+ which fixes a segmentation fault when all binded parameters are NULL
+ - adapt test.pl to avoid warnings with postgresql-7.0
+ - added support for 'COPY FROM STDIN' and 'COPY TO STDOUT'
+ - added patch from Mark Stosberg <mark@summersault.com>
+ to enhance the table_attributes subroutine
+
+0.93 Sep 29, 1999
+ - it is required now to set the environment variables POSTGRES_INCLUDE
+ and POSTGRES_LIB for compiling the module.
+ - add Win32 port from Bob Kline <bkline@rksystems.com>.
+ - support for all large-object functions via the func
+ interface.
+ - fixed bug with placeholders and casts spotted by
+ mschout@gkg.net
+ - replaced the method attributes by the method table_attributes,
+ from Scott Williams <scott@james.com>.
+ - fix type definitions for type_info_all().
+ bug spotted by "carlos" <emarcet@intramed.net.ar>.
+ - now the Pg-specific quote() method also evaluates the
+ data-type paramater.
+
+0.92 Jun 16, 1999
+ - proposal from Philip Warner <pjw@rhyme.com.au>:
+ increase BUFSIZE from 1024 to 32768 in order to improve
+ I/O performance.
+ - bug-fix in Makefile.PL for $POSTGRES_HOME not defined
+ spotted by mdalphin@amgen.com (Mark Dalphin)
+ - bug-fix for data-type datetime in type_info_all
+ spotted by Alan Grover <awgrover@iconnect-inc.com>
+ - bug-fix for escaped 's spotted by Hankin <hankin@consultco.com>
+ - removed 'large objects' related tests from test.pl
+
+0.91 Feb 14, 1999
+ - removed restriction for commercial use in copyright
+ - corrected DATA_TYPE in type_info_all()
+
+0.90 Jan 15, 1998
+ - discard parameter authtype from connect string
+ - remove work-around for bug in the large object
+ interface of postgresql
+
+0.89 Nov 05, 1998
+ - bug-fix from Jan Iven <j.iven@rz.uni-sb.de>:
+ fix problem with quoting Null in bind variables.
+
+0.88 Oct 10, 1998
+ - fixed blob_read
+ - suppressed warning when testing DBI::errstr
+
+0.87 Sep 05, 1998
+ - Pg.xs adapted to Driver.xst from DBI-1.0
+ - major rewrite of module documentation
+ - major rewrite of the test script
+ - use built-in DBI method for $dbh->do
+ - add macro dHTR in order to avoid compile errors
+ with threaded perl5.005
+ - renamed attribute AutoEscape to pg_auto_escape
+ - renamed attribute SIZE to pg_size
+ - new attribute pg_type
+ - added support for DBI->data_sources($driver)
+ - added support for $dbh->table_info
+ - blob_read documented and added to test.pl
+ - added support for attr parameter in bind_param()
+
+0.86 Aug 21, 1998
+ - added /usr/lib/ to search path for libpq.
+ - added ChopBlanks, patch from
+ Victor Krasinsky <victor@rdovira.lviv.ua>
+ - changed test.pl to test multiple database handles
+
+0.85 July 19, 1998
+ - non-printable characters in parameters will not be
+ converted to '.'. They are passed unchanged to the
+ database.
+
+0.84 July 18, 1998
+ - bug-fix from Max Cohan <mcohan@adnc.net>:
+ check for \xxx presentation before escaping backslash
+ in parameters.
+ - introduce new database handle attribute AutoEscape, which
+ controls escaping of quotes and backslashes in parameters.
+ When set to on, all quotes except at the beginning and
+ at the end of a line will be escaped and all backslashes
+ except when used to indicate an octal presentation (\xxx)
+ will be escaped. Default of AutoEscape is on.
+
+0.83 July 10, 1998
+ - bug-fix from Max Cohan <mcohan@adnc.net>:
+ using traces together with undef in place-holders dumped
+ core.
+
+0.82 June 20, 1998
+ - bug-fix from Matthew Lenz <matthew@nocturnal.org>:
+ corrected include path in Makefile.PL .
+ - added 'use strict;' to test.pl
+
+0.81 June 13, 1998
+ - bug-fix from Rolf Grossmann <grossman@securitas.net>:
+ undefined parameters in an execute statement will be
+ translated from 'undef' to 'NULL'. Also every parameter
+ for bind_param() will be quoted by default (escape quote
+ and backslash). Appropriate tests have been added to test.pl.
+ - change ping method to use libpq-interface.
+
+0.80 June 07, 1998
+ - adapted to postgresql-6.4:
+ the backend protocol has changed, which needs an adapted
+ ping method. A ping-test has been added to the test-script.
+ Also some type identifiers have changed.
+
+0.73 June 03, 1998
+ - changed include directives in Makefile.PL from
+ archlib to installarchlib and from sitearch to
+ installsitearch (Tony.Curtis@vcpc.univie.ac.at).
+ - applied patch from Junio Hamano <junio@twinsun.com>
+ quote method also doubles backslash.
+
+0.72 April 20, 1998
+ - applied patch from Michael J Schout <mschout@gkg.net>
+ which fixed the bug with queries containing the cast
+ operator.
+ - applied patch from "Irving Reid" <irving@tor.securecomputing.com>
+ which fixed a memory leak.
+
+0.71 April 04, 1998
+ - applied patch from "Irving Reid"
+ <irving@tor.securecomputing.com> which fixed the
+ the problem with the InactiveDestroy message.
+
+0.70 March 28, 1998
+ - linking again with the shared version of libpq
+ due to problems on several operating systems.
+
+0.69 March 6, 1998
+ - expanded the search path for include files
+ - module is now linked with static libpq.a
+
+0.68 March 3, 1998
+ - return to UNIX domain sockets in test-scripts
+
+0.67 February 21, 1998
+ - remove part of Driver.xst due to compile
+ error on some systems.
+
+0.66 February 19, 1998
+ - remove defines in Pg.h so that
+ it compiles also with postgresql-6.2.1
+ - changed ping method: set RaiseError=0
+
+0.65 February 14, 1998
+ - adapted to changes in DBI-0.91, so that the
+ default setting for AutoCommit and PrintError is
+ again conformant to the DBI specs.
+
+0.64 February 01, 1998
+ - changed syntax of data_source (ODBC-conformant):
+ 'dbi:Pg:dbname=dbname;host=host;port=port'
+ !!! PLEASE ADAPT YOUR SCRIPTS !!!
+ - implemented place-holders
+ - implemented ping-method
+ - added support for $dbh->{RaiseError} and $dbh->{PrintError},
+ note: DBI-default for PrintError is on !
+ - allow commit and rollback only if AutoCommit = off
+ - added documentation for $dbh->tables;
+ - new method to get meta-information about a given table:
+ $dbh->DBD::Pg::db::attributes($table);
+ - host-parameter in test.pl is set explicitly to localhost
+
+0.63 October 05, 1997
+ - adapted to PostgreSQL-6.2:
+ o $sth->rows as well as $sth->execute
+ and $sth->do return the number of
+ affected rows even for non-Select
+ statements.
+ o support for password authorization added,
+ please check the man-page for pg_passwd.
+ - the data_source parameter of the connect
+ method accepts two additional parameters
+ which are treated as host and port:
+ DBI->connect("dbi:Pg:dbname:host:port", "uid", "pwd")
+ - support for AutoCommit, please read the
+ module documentation for impacts on your
+ scripts !
+ - more perl-ish handling of data type bool,
+ please read the module documentation for
+ impacts on your scripts !
+
+0.62 August 26, 1997
+ - added blobs/README
+
+0.61 August 23, 1997
+ - adapted to DBI-0.89/Driver.xst
+ - added support for blob_read
+
+0.52 August 15, 1997
+ - added support for literal $sth->{'TYPE'},
+ pg_type.pl / pg_type.pm.
+
+0.51 August 12, 1997
+ - changed attributes to be DBI conformant:
+ o OID_STATUS to pg_oid_status
+ o CMD_STATUS to pg_cmd_status
+
+0.5 August 05, 1997
+ - support for user authentication
+ - support for bind_columns
+ - added $dbh->tables
+
+0.4 Jun 24, 1997
+ - adapted to DBI-0.84:
+ o new syntax for DBI->connect !
+ o execute returns 0E0 -> n for SELECT stmt
+ -1 for non SELECT stmt
+ -2 on error
+ - new attribute $sth->{'OID_STATUS'}
+ - new attribute $sth->{'CMD_STATUS'}
+
+0.3 Apr 24, 1997
+ - bug fix release, ( still alpha ! )
+
+0.2 Mar 13, 1997
+ - complete rewrite, ( still alpha ! )
+
+0.1 Feb 15, 1997
+ - creation, ( totally pre-alpha ! )
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+Pg.h
+Pg.pm
+Pg.xs
+README
+README.win32
+dbd-pg.pod
+dbdimp.c
+dbdimp.h
+eg/ApacheDBI.pl
+eg/lotest.pl
+eg/notify_test.patch
+t/00basic.t
+t/01connect.t
+t/01constants.t
+t/01setup.t
+t/02prepare.t
+t/03bind.t
+t/04execute.t
+t/05fetch.t
+t/06disconnect.t
+t/07reuse.t
+t/08txn.t
+t/09autocommit.t
+t/11quoting.t
+t/12placeholders.t
+t/13pgtype.t
+t/15funct.t
+t/99cleanup.t
+t/lib/App/Info.pm
+t/lib/App/Info/Handler.pm
+t/lib/App/Info/Handler/Prompt.pm
+t/lib/App/Info/RDBMS.pm
+t/lib/App/Info/RDBMS/PostgreSQL.pm
+t/lib/App/Info/Request.pm
+t/lib/App/Info/Util.pm
--- /dev/null
+
+# $Id: Makefile.PL,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+use ExtUtils::MakeMaker;
+use Config;
+use strict;
+
+use DBI 1.00;
+use DBI::DBD;
+
+my $lib;
+BEGIN {
+ my %sep = (MacOS => ':',
+ MSWin32 => '\\',
+ os2 => '\\',
+ VMS => '\\',
+ NetWare => '\\',
+ dos => '\\');
+ my $s = $sep{$^O} || '/';
+ $lib = join $s, 't', 'lib';
+}
+
+use lib $lib;
+print "Configuring Pg\n";
+print "Remember to actually read the README file !\n";
+
+my $POSTGRES_INCLUDE;
+my $POSTGRES_LIB;
+
+if ((!$ENV{POSTGRES_INCLUDE} or !$ENV{POSTGRES_LIB}) and !$ENV{POSTGRES_HOME}) {
+ # Use App::Info to get the data we need.
+ require App::Info::RDBMS::PostgreSQL;
+ require App::Info::Handler::Prompt;
+ my $p = App::Info::Handler::Prompt->new;
+ my $pg = App::Info::RDBMS::PostgreSQL->new(on_unknown => $p);
+ $POSTGRES_INCLUDE = $pg->inc_dir;
+ $POSTGRES_LIB = $pg->lib_dir;
+} elsif ((!$ENV{POSTGRES_INCLUDE} or !$ENV{POSTGRES_LIB}) and $ENV{POSTGRES_HOME}) {
+ $POSTGRES_INCLUDE = "$ENV{POSTGRES_HOME}/include";
+ $POSTGRES_LIB = "$ENV{POSTGRES_HOME}/lib";
+} else {
+ $POSTGRES_INCLUDE = "$ENV{POSTGRES_INCLUDE}";
+ $POSTGRES_LIB = "$ENV{POSTGRES_LIB}";
+}
+
+my $os = $^O;
+print "OS: $os\n";
+
+my $dbi_arch_dir;
+if ($os eq 'MSWin32') {
+ $dbi_arch_dir = "\$(INSTALLSITEARCH)/auto/DBI";
+} else {
+ $dbi_arch_dir = dbd_dbi_arch_dir();
+}
+
+my %opts = (
+ NAME => 'DBD::Pg',
+ VERSION_FROM => 'Pg.pm',
+ INC => "-I$POSTGRES_INCLUDE -I$dbi_arch_dir",
+ OBJECT => "Pg\$(OBJ_EXT) dbdimp\$(OBJ_EXT)",
+ LIBS => ["-L$POSTGRES_LIB -lpq"],
+ AUTHOR => 'http://gborg.postgresql.org/project/dbdpg/projdisplay.php',
+ ABSTRACT => 'PostgreSQL database driver for the DBI module',
+ PREREQ_PM => { 'Test::Simple' => 0.17 }, # Need Test::More
+);
+
+if ($os eq 'hpux') {
+ my $osvers = $Config{osvers};
+ if ($osvers < 10) {
+ print "Warning: Forced to build static not dynamic on $os $osvers.\a\n";
+ $opts{LINKTYPE} = 'static';
+ }
+}
+
+if ($Config{dlsrc} =~ /dl_none/) {
+ $opts{LINKTYPE} = 'static';
+}
+
+WriteMakefile(%opts);
+
+exit(0);
+
+# end of Makefile.PL
--- /dev/null
+/*
+ $Id: Pg.h,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+ Copyright (c) 1997,1998,1999,2000 Edmund Mergl
+ Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the Perl README file.
+
+*/
+
+
+#ifdef WIN32
+static int errno;
+#endif
+
+#include "libpq-fe.h"
+
+#ifdef NEVER
+#include<sys/stat.h>
+#include "libpq/libpq-fs.h"
+#endif
+#ifndef INV_READ
+#define INV_READ 0x00040000
+#endif
+#ifndef INV_WRITE
+#define INV_WRITE 0x00020000
+#endif
+
+#ifdef BUFSIZ
+#undef BUFSIZ
+#endif
+/* this should improve I/O performance for large objects */
+#define BUFSIZ 32768
+
+
+#define NEED_DBIXS_VERSION 93
+
+#include <DBIXS.h> /* installed by the DBI module */
+
+#include "dbdimp.h" /* read in our implementation details */
+
+#include <dbd_xsh.h> /* installed by the DBI module */
+
+
+/* end of Pg.h */
--- /dev/null
+
+# $Id: Pg.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $
+#
+# Copyright (c) 1997,1998,1999,2000 Edmund Mergl
+# Copyright (c) 2002 Jeffrey W. Baker
+# Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+
+require 5.004;
+
+$DBD::Pg::VERSION = '1.22';
+
+{
+ package DBD::Pg;
+
+ use DBI ();
+ use DynaLoader ();
+ use Exporter ();
+ @ISA = qw(DynaLoader Exporter);
+
+ %EXPORT_TAGS = (
+ pg_types => [ qw(
+ PG_BOOL PG_BYTEA PG_CHAR PG_INT8 PG_INT2 PG_INT4 PG_TEXT PG_OID
+ PG_FLOAT4 PG_FLOAT8 PG_ABSTIME PG_RELTIME PG_TINTERVAL PG_BPCHAR
+ PG_VARCHAR PG_DATE PG_TIME PG_DATETIME PG_TIMESPAN PG_TIMESTAMP
+ )]);
+
+ Exporter::export_ok_tags('pg_types');
+
+ require_version DBI 1.00;
+
+ bootstrap DBD::Pg $VERSION;
+
+ $err = 0; # holds error code for DBI::err
+ $errstr = ""; # holds error string for DBI::errstr
+ $drh = undef; # holds driver handle once initialized
+
+ sub driver{
+ return $drh if $drh;
+ my($class, $attr) = @_;
+
+ $class .= "::dr";
+
+ # not a 'my' since we use it above to prevent multiple drivers
+
+ $drh = DBI::_new_drh($class, {
+ 'Name' => 'Pg',
+ 'Version' => $VERSION,
+ 'Err' => \$DBD::Pg::err,
+ 'Errstr' => \$DBD::Pg::errstr,
+ 'Attribution' => 'PostgreSQL DBD by Edmund Mergl',
+ });
+
+ $drh;
+ }
+
+ ## Used by both the dr and db packages
+ sub pg_server_version {
+ my $dbh = shift;
+ return $dbh->{pg_server_version} if defined $dbh->{pg_server_version};
+ my ($version) = $dbh->selectrow_array("SELECT version();");
+ return 0 unless $version =~ /^PostgreSQL ([\d\.]+)/;
+ $dbh{pg_server_version} = $1;
+ return $dbh{pg_server_version};
+ }
+
+ sub pg_use_catalog {
+ my $dbh = shift;
+ my $version = DBD::Pg::pg_server_version($dbh);
+ $version =~ /^(\d+\.\d+)/;
+ return $1 < 7.3 ? "" : "pg_catalog.";
+ }
+
+ 1;
+}
+
+
+{ package DBD::Pg::dr; # ====== DRIVER ======
+ use strict;
+
+ sub data_sources {
+ my $drh = shift;
+ my $dbh = DBD::Pg::dr::connect($drh, 'dbname=template1') or return undef;
+ $dbh->{AutoCommit} = 1;
+ my $CATALOG = DBD::Pg::pg_use_catalog($dbh);
+ my $sth = $dbh->prepare("SELECT datname FROM ${CATALOG}pg_database ORDER BY datname");
+ $sth->execute or return undef;
+ my (@sources, @datname);
+ while (@datname = $sth->fetchrow_array) {
+ push @sources, "dbi:Pg:dbname=$datname[0]";
+ }
+ $sth->finish;
+ $dbh->disconnect;
+ return @sources;
+ }
+
+
+ sub connect {
+ my($drh, $dbname, $user, $auth)= @_;
+
+ # create a 'blank' dbh
+
+ my $Name = $dbname;
+ $Name =~ s/^.*dbname\s*=\s*//;
+ $Name =~ s/\s*;.*$//;
+
+ $user = "" unless defined($user);
+ $auth = "" unless defined($auth);
+
+ $user = $ENV{DBI_USER} if $user eq "";
+ $auth = $ENV{DBI_PASS} if $auth eq "";
+
+ $user = "" unless defined($user);
+ $auth = "" unless defined($auth);
+
+ my($dbh) = DBI::_new_dbh($drh, {
+ 'Name' => $Name,
+ 'User' => $user, 'CURRENT_USER' => $user,
+ });
+
+ # Connect to the database..
+ DBD::Pg::db::_login($dbh, $dbname, $user, $auth) or return undef;
+
+ $dbh;
+ }
+
+}
+
+
+{ package DBD::Pg::db; # ====== DATABASE ======
+ use strict;
+ use Carp ();
+
+ sub prepare {
+ my($dbh, $statement, @attribs)= @_;
+
+ # create a 'blank' sth
+
+ my $sth = DBI::_new_sth($dbh, {
+ 'Statement' => $statement,
+ });
+
+ DBD::Pg::st::_prepare($sth, $statement, @attribs) or return undef;
+
+ $sth;
+ }
+
+
+ sub ping {
+ my($dbh) = @_;
+
+ local $SIG{__WARN__} = sub { } if $dbh->{PrintError};
+ local $dbh->{RaiseError} = 0 if $dbh->{RaiseError};
+ my $ret = DBD::Pg::db::_ping($dbh);
+
+ return $ret;
+ }
+
+ # Column expected in statement handle returned.
+ # table_cat, table_schem, table_name, column_name, data_type, type_name,
+ # column_size, buffer_length, DECIMAL_DIGITS, NUM_PREC_RADIX, NULLABLE,
+ # REMARKS, COLUMN_DEF, SQL_DATA_TYPE, SQL_DATETIME_SUB, CHAR_OCTET_LENGTH,
+ # ORDINAL_POSITION, IS_NULLABLE
+ # The result set is ordered by TABLE_CAT, TABLE_SCHEM,
+ # TABLE_NAME and ORDINAL_POSITION.
+
+ sub column_info {
+ my ($dbh) = shift;
+ my @attrs = @_;
+ # my ($dbh, $catalog, $schema, $table, $column) = @_;
+ my $CATALOG = DBD::Pg::pg_use_catalog($dbh);
+
+ my @wh = ();
+ my @flds = qw/catname n.nspname c.relname a.attname/;
+
+ for my $idx (0 .. $#attrs) {
+ next if ($flds[$idx] eq 'catname'); # Skip catalog
+ if(defined $attrs[$idx] and length $attrs[$idx]) {
+ # Insure that the value is enclosed in single quotes.
+ $attrs[$idx] =~ s/^'?(\w+)'?$/'$1'/;
+ if ($attrs[$idx] =~ m/[,%]/) {
+ # contains a meta character.
+ push( @wh, q{( } . join ( " OR "
+ , map { m/\%/
+ ? qq{$flds[$idx] ILIKE $_ }
+ : qq{$flds[$idx] = $_ }
+ } (split /,/, $attrs[$idx]) )
+ . q{ )}
+ );
+ }
+ else {
+ push( @wh, qq{$flds[$idx] = $attrs[$idx]} );
+ }
+ }
+ }
+
+ my $wh = ""; # ();
+ $wh = join( " AND ", '', @wh ) if (@wh);
+ my $version = DBD::Pg::pg_server_version($dbh);
+ $version =~ /^(\d+\.\d+)/;
+ $version = $1;
+ my $showschema = $version < 7.3 ? "NULL::text" : "n.nspname";
+ my $schemajoin = $version < 7.3 ? "" : "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)";
+ my $col_info_sql = qq{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , $showschema AS "TABLE_SCHEM"
+ , c.relname AS "TABLE_NAME"
+ , a.attname AS "COLUMN_NAME"
+ , t.typname AS "DATA_TYPE"
+ , NULL::text AS "TYPE_NAME"
+ , a.attlen AS "COLUMN_SIZE"
+ , NULL::text AS "BUFFER_LENGTH"
+ , NULL::text AS "DECIMAL_DIGITS"
+ , NULL::text AS "NUM_PREC_RADIX"
+ , a.attnotnull AS "NULLABLE"
+ , NULL::text AS "REMARKS"
+ , a.atthasdef AS "COLUMN_DEF"
+ , NULL::text AS "SQL_DATA_TYPE"
+ , NULL::text AS "SQL_DATETIME_SUB"
+ , NULL::text AS "CHAR_OCTET_LENGTH"
+ , a.attnum AS "ORDINAL_POSITION"
+ , a.attnotnull AS "IS_NULLABLE"
+ , a.atttypmod as atttypmod
+ , a.attnotnull as attnotnull
+ , a.atthasdef as atthasdef
+ , a.attnum as attnum
+ FROM
+ ${CATALOG}pg_attribute a
+ , ${CATALOG}pg_type t
+ , ${CATALOG}pg_class c
+ $schemajoin
+ WHERE
+ a.attrelid = c.oid
+ AND a.attnum >= 0
+ AND t.oid = a.atttypid
+ AND c.relkind in ('r','v')
+ $wh
+ ORDER BY 2, 3, 4
+ };
+
+ my $sth = $dbh->prepare( $col_info_sql ) or return undef;
+ $sth->execute();
+
+ return $sth;
+ }
+
+ sub primary_key_info {
+ my $dbh = shift;
+ my ($catalog, $schema, $table) = @_;
+ my @attrs = @_;
+ my $CATALOG = DBD::Pg::pg_use_catalog($dbh);
+
+ # TABLE_CAT:, TABLE_SCHEM:, TABLE_NAME:, COLUMN_NAME:, KEY_SEQ:
+ # , PK_NAME:
+
+ my @wh = (); my @dat = (); # Used to hold data for the attributes.
+
+ my $version = DBD::Pg::pg_server_version($dbh);
+ $version =~ /^(\d+\.\d+)/;
+ $version = $1;
+
+ my @flds = qw/catname u.usename bc.relname/;
+ $flds[1] = 'n.nspname' unless ($version < 7.3);
+
+ for my $idx (0 .. $#attrs) {
+ next if ($flds[$idx] eq 'catname'); # Skip catalog
+ if(defined $attrs[$idx] and length $attrs[$idx]) {
+ if ($attrs[$idx] =~ m/[,%_?]/) {
+ # contains a meta character.
+ push( @wh, q{( } . join ( " OR "
+ , map { push(@dat, $_);
+ m/[%_?]/
+ ? qq{$flds[$idx] iLIKE ? }
+ : qq{$flds[$idx] = ? }
+ } (split /,/, $attrs[$idx]) )
+ . q{ )}
+ );
+ }
+ else {
+ push( @dat, $attrs[$idx] );
+ push( @wh, qq{$flds[$idx] = ? } );
+ }
+ }
+ }
+
+ my $wh = '';
+ $wh = join( " AND ", '', @wh ) if (@wh);
+
+ # Base primary key selection query borrowed from phpPgAdmin.
+ my $showschema = $version < 7.3 ? "NULL::text" : "n.nspname";
+ my $schemajoin = $version < 7.3 ? "" : "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = bc.relnamespace)";
+ my $pri_key_sql = qq{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , $showschema AS "TABLE_SCHEM"
+ , bc.relname AS "TABLE_NAME"
+ , a.attname AS "COLUMN_NAME"
+ , a.attnum AS "KEY_SEQ"
+ , ic.relname AS "PK_NAME"
+ FROM
+ ${CATALOG}pg_index i
+ , ${CATALOG}pg_attribute a
+ , ${CATALOG}pg_class ic
+ , ${CATALOG}pg_class bc
+ $schemajoin
+ WHERE
+ i.indrelid = bc.oid
+ AND i.indexrelid = ic.oid
+ AND
+ (
+ i.indkey[0] = a.attnum
+ OR
+ i.indkey[1] = a.attnum
+ OR
+ i.indkey[2] = a.attnum
+ OR
+ i.indkey[3] = a.attnum
+ OR
+ i.indkey[4] = a.attnum
+ OR
+ i.indkey[5] = a.attnum
+ OR
+ i.indkey[6] = a.attnum
+ OR
+ i.indkey[7] = a.attnum
+ OR
+ i.indkey[8] = a.attnum
+ OR
+ i.indkey[9] = a.attnum
+ OR
+ i.indkey[10] = a.attnum
+ OR
+ i.indkey[11] = a.attnum
+ OR
+ i.indkey[12] = a.attnum
+ )
+ AND a.attrelid = bc.oid
+ AND i.indproc = '0'::oid
+ AND i.indisprimary = 't'
+ $wh
+ ORDER BY 2, 3, 5
+ };
+
+ my $sth = $dbh->prepare( $pri_key_sql ) or return undef;
+ $sth->execute(@dat);
+
+ return $sth;
+ }
+
+ sub foreign_key_info {
+ # todo: verify schema work as expected
+ # add code to handle multiple-column keys correctly
+ # return something nicer for pre-7.3?
+ # try to clean up SQL, perl code
+ # create a test script?
+
+ my $dbh = shift;
+ my ($pk_catalog, $pk_schema, $pk_table,
+ $fk_catalog, $fk_schema, $fk_table) = @_;
+
+ # this query doesn't work for Postgres before 7.3
+ my $version = $dbh->pg_server_version;
+ $version =~ /^(\d+)\.(\d)/;
+ return undef if ($1.$2 < 73);
+
+ # Used to hold data for the attributes.
+ my @dat = ();
+
+ # SQL to find primary/unique keys of a table
+ my $pkey_sql = qq{
+ SELECT
+ NULL::text AS PKTABLE_CAT,
+ pknam.nspname AS PKTABLE_SCHEM,
+ pkc.relname AS PKTABLE_NAME,
+ pka.attname AS PKCOLUMN_NAME,
+ NULL::text AS FKTABLE_CAT,
+ NULL::text AS FKTABLE_SCHEM,
+ NULL::text AS FKTABLE_NAME,
+ NULL::text AS FKCOLUMN_NAME,
+ pkcon.conkey[1] AS KEY_SEQ,
+ CASE
+ WHEN pkcon.confupdtype = 'c' THEN 0
+ WHEN pkcon.confupdtype = 'r' THEN 1
+ WHEN pkcon.confupdtype = 'n' THEN 2
+ WHEN pkcon.confupdtype = 'a' THEN 3
+ WHEN pkcon.confupdtype = 'd' THEN 4
+ END AS UPDATE_RULE,
+ CASE
+ WHEN pkcon.confdeltype = 'c' THEN 0
+ WHEN pkcon.confdeltype = 'r' THEN 1
+ WHEN pkcon.confdeltype = 'n' THEN 2
+ WHEN pkcon.confdeltype = 'a' THEN 3
+ WHEN pkcon.confdeltype = 'd' THEN 4
+ END AS DELETE_RULE,
+ NULL::text AS FK_NAME,
+ pkcon.conname AS PK_NAME,
+ CASE
+ WHEN pkcon.condeferrable = 'f' THEN 7
+ WHEN pkcon.condeferred = 't' THEN 6
+ WHEN pkcon.condeferred = 'f' THEN 5
+ END AS DEFERRABILITY,
+ CASE
+ WHEN pkcon.contype = 'p' THEN 'PRIMARY'
+ WHEN pkcon.contype = 'u' THEN 'UNIQUE'
+ END AS UNIQUE_OR_PRIMARY
+ FROM
+ pg_constraint AS pkcon
+ JOIN
+ pg_class pkc ON pkc.oid=pkcon.conrelid
+ JOIN
+ pg_namespace pknam ON pkcon.connamespace=pknam.oid
+ JOIN
+ pg_attribute pka ON pka.attnum=pkcon.conkey[1] AND pka.attrelid=pkc.oid
+ };
+
+ # SQL to find foreign keys of a table
+ my $fkey_sql = qq{
+ SELECT
+ NULL::text AS PKTABLE_CAT,
+ pknam.nspname AS PKTABLE_SCHEM,
+ pkc.relname AS PKTABLE_NAME,
+ pka.attname AS PKCOLUMN_NAME,
+ NULL::text AS FKTABLE_CAT,
+ fknam.nspname AS FKTABLE_SCHEM,
+ fkc.relname AS FKTABLE_NAME,
+ fka.attname AS FKCOLUMN_NAME,
+ fkcon.conkey[1] AS KEY_SEQ,
+ CASE
+ WHEN fkcon.confupdtype = 'c' THEN 0
+ WHEN fkcon.confupdtype = 'r' THEN 1
+ WHEN fkcon.confupdtype = 'n' THEN 2
+ WHEN fkcon.confupdtype = 'a' THEN 3
+ WHEN fkcon.confupdtype = 'd' THEN 4
+ END AS UPDATE_RULE,
+ CASE
+ WHEN fkcon.confdeltype = 'c' THEN 0
+ WHEN fkcon.confdeltype = 'r' THEN 1
+ WHEN fkcon.confdeltype = 'n' THEN 2
+ WHEN fkcon.confdeltype = 'a' THEN 3
+ WHEN fkcon.confdeltype = 'd' THEN 4
+ END AS DELETE_RULE,
+ fkcon.conname AS FK_NAME,
+ pkcon.conname AS PK_NAME,
+ CASE
+ WHEN fkcon.condeferrable = 'f' THEN 7
+ WHEN fkcon.condeferred = 't' THEN 6
+ WHEN fkcon.condeferred = 'f' THEN 5
+ END AS DEFERRABILITY,
+ CASE
+ WHEN pkcon.contype = 'p' THEN 'PRIMARY'
+ WHEN pkcon.contype = 'u' THEN 'UNIQUE'
+ END AS UNIQUE_OR_PRIMARY
+ FROM
+ pg_constraint AS fkcon
+ JOIN
+ pg_constraint AS pkcon ON fkcon.confrelid=pkcon.conrelid
+ AND fkcon.confkey=pkcon.conkey
+ JOIN
+ pg_class fkc ON fkc.oid=fkcon.conrelid
+ JOIN
+ pg_class pkc ON pkc.oid=fkcon.confrelid
+ JOIN
+ pg_namespace pknam ON pkcon.connamespace=pknam.oid
+ JOIN
+ pg_namespace fknam ON fkcon.connamespace=fknam.oid
+ JOIN
+ pg_attribute fka ON fka.attnum=fkcon.conkey[1] AND fka.attrelid=fkc.oid
+ JOIN
+ pg_attribute pka ON pka.attnum=pkcon.conkey[1] AND pka.attrelid=pkc.oid
+ };
+
+ # if schema are provided, use this SQL
+ my $pk_schema_sql = " AND pknam.nspname = ? ";
+ my $fk_schema_sql = " AND fknam.nspname = ? ";
+
+ my $key_sql;
+
+ # if $fk_table: generate SQL stub, which will be same
+ # whether or not $pk_table supplied
+ if ($fk_table)
+ {
+ $key_sql = $fkey_sql . qq{
+ WHERE
+ fkc.relname = ?
+ };
+ push @dat, $fk_table;
+
+ if ($fk_schema)
+ {
+ $key_sql .= $fk_schema_sql;
+ push @dat,$fk_schema;
+ }
+ }
+
+ # if $fk_table and $pk_table: (defined by DBI, not SQL/CLI)
+ # return foreign key of $fk_table that refers to $pk_table
+ # (if any)
+ if ($pk_table and $fk_table)
+ {
+ $key_sql .= qq{
+ AND
+ pkc.relname = ?
+ };
+ push @dat, $pk_table;
+
+ if ($pk_schema)
+ {
+ $key_sql .= $pk_schema_sql;
+ push @dat,$pk_schema;
+ }
+ }
+
+ # if $fk_table but no $pk_table:
+ # return all foreign keys of $fk_table, and all
+ # primary keys of tables to which $fk_table refers
+ if (!$pk_table and $fk_table)
+ {
+ # find primary/unique keys referenced by $fk_table
+ # (this one is a little tricky)
+ $key_sql .= ' UNION ' . $pkey_sql . qq{
+ WHERE
+ pkcon.conname IN
+ (
+ SELECT
+ pkcon.conname
+ FROM
+ pg_constraint AS fkcon
+ JOIN
+ pg_constraint AS pkcon ON fkcon.confrelid=pkcon.conrelid AND
+ fkcon.confkey=pkcon.conkey
+ JOIN
+ pg_class fkc ON fkc.oid=fkcon.conrelid
+ WHERE
+ fkc.relname = ?
+ )
+ };
+ push @dat, $fk_table;
+
+ if ($fk_schema)
+ {
+ $key_sql .= $pk_schema_sql;
+ push @dat,$fk_schema;
+ }
+ }
+
+ # if $pk_table but no $fk_table:
+ # return primary key of $pk_table and all foreign keys
+ # that reference $pk_table
+ # question: what about unique keys?
+ # (DBI and SQL/CLI both state to omit unique keys)
+
+ if ($pk_table and !$fk_table)
+ {
+ # find primary key (only!) of $pk_table
+ $key_sql = $pkey_sql . qq{
+ WHERE
+ pkc.relname = ?
+ AND
+ pkcon.contype = 'p'
+ };
+ @dat = ($pk_table);
+
+ if ($pk_schema)
+ {
+ $key_sql .= $pk_schema_sql;
+ push @dat,$pk_schema;
+ }
+
+ # find all foreign keys that reference $pk_table
+ $key_sql .= 'UNION ' . $fkey_sql . qq{
+ WHERE
+ pkc.relname = ?
+ AND
+ pkcon.contype = 'p'
+ };
+ push @dat, $pk_table;
+
+ if ($pk_schema)
+ {
+ $key_sql .= $fk_schema_sql;
+ push @dat,$pk_schema;
+ }
+ }
+
+ return undef unless $key_sql;
+ my $sth = $dbh->prepare( $key_sql ) or
+ return undef;
+ $sth->execute(@dat);
+
+ return $sth;
+ }
+
+
+ sub table_info { # DBI spec: TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TABLE_TYPE, REMARKS
+ my $dbh = shift;
+ my ($catalog, $schema, $table, $type) = @_;
+ my @attrs = @_;
+
+ my $tbl_sql = ();
+
+ my $version = DBD::Pg::pg_server_version($dbh);
+ $version =~ /^(\d+\.\d+)/;
+ $version = $1;
+ my $CATALOG = DBD::Pg::pg_use_catalog($dbh);
+
+ if ( # Rules 19a
+ (defined $catalog and $catalog eq '%')
+ and (defined $schema and $schema eq '')
+ and (defined $table and $table eq '')
+ ) {
+ $tbl_sql = q{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , NULL::text AS "TABLE_TYPE"
+ , NULL::text AS "REMARKS"
+ };
+ }
+ elsif (# Rules 19b
+ (defined $catalog and $catalog eq '')
+ and (defined $schema and $schema eq '%')
+ and (defined $table and $table eq '')
+ ) {
+ $tbl_sql = ($version < 7.3) ? q{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , NULL::text AS "TABLE_TYPE"
+ , NULL::text AS "REMARKS"
+ } : q{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , n.nspname AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , NULL::text AS "TABLE_TYPE"
+ , NULL::text AS "REMARKS"
+ FROM pg_catalog.pg_namespace n
+ ORDER BY 1
+ };
+ }
+ elsif (# Rules 19c
+ (defined $catalog and $catalog eq '')
+ and (defined $schema and $schema eq '')
+ and (defined $table and $table eq '')
+ and (defined $type and $type eq '%')
+ ) {
+ # From the postgresql 7.2.1 manual 3.5 pg_class
+ # 'r' = ordinary table
+ #, 'i' = index
+ #, 'S' = sequence
+ #, 'v' = view
+ #, 's' = special
+ #, 't' = secondary TOAST table
+ $tbl_sql = q{
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'table' AS "TABLE_TYPE"
+ , 'ordinary table - r' AS "REMARKS"
+ union
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'index' AS "TABLE_TYPE"
+ , 'index - i' AS "REMARKS"
+ union
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'sequence' AS "TABLE_TYPE"
+ , 'sequence - S' AS "REMARKS"
+ union
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'view' AS "TABLE_TYPE"
+ , 'view - v' AS "REMARKS"
+ union
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'special' AS "TABLE_TYPE"
+ , 'special - s' AS "REMARKS"
+ union
+ SELECT
+ NULL::text AS "TABLE_CAT"
+ , NULL::text AS "TABLE_SCHEM"
+ , NULL::text AS "TABLE_NAME"
+ , 'secondary' AS "TABLE_TYPE"
+ , 'secondary TOAST table - t' AS "REMARKS"
+ };
+ }
+ else {
+ # Default SQL
+ my $showschema = $version < 7.3 ? "NULL::text" : "n.nspname";
+ my $schemajoin = $version < 7.3 ? "" : "LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)";
+ my $schemacase = $version < 7.3 ? "CASE WHEN c.relname ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END" :
+ "CASE WHEN n.nspname ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END";
+ $tbl_sql = qq{
+ SELECT NULL::text AS "TABLE_CAT"
+ , $showschema AS "TABLE_SCHEM"
+ , c.relname AS "TABLE_NAME"
+ , CASE
+ WHEN c.relkind = 'v' THEN 'VIEW'
+ ELSE $schemacase
+ END AS "TABLE_TYPE"
+ , d.description AS "REMARKS"
+ FROM ${CATALOG}pg_user AS u
+ , ${CATALOG}pg_class AS c
+ LEFT JOIN
+ ${CATALOG}pg_description AS d
+ ON (c.relfilenode = d.objoid AND d.objsubid = 0)
+ $schemajoin
+ WHERE
+ ((c.relkind = 'r'
+ AND c.relhasrules = FALSE) OR
+ (c.relkind = 'v'
+ AND c.relhasrules = TRUE))
+ AND c.relname !~ '^xin[vx][0-9]+'
+ AND c.relowner = u.usesysid
+ ORDER BY 1, 2, 3
+ };
+
+ # Did we receive any arguments?
+ if (@attrs) {
+ my @wh = ();
+ my @flds = qw/catname n.nspname c.relname c.relkind/;
+
+ for my $idx (0 .. $#attrs) {
+ next if ($flds[$idx] eq 'catname'); # Skip catalog
+ if(defined $attrs[$idx] and length $attrs[$idx]) {
+ # Change the "name" of the types to the real value.
+ if ($flds[$idx] =~ m/relkind/) {
+ $attrs[$idx] =~ s/^\'?table\'?/'r'/i;
+ $attrs[$idx] =~ s/^\'?index\'?/'i'/i;
+ $attrs[$idx] =~ s/^\'?sequence\'?/'S'/i;
+ $attrs[$idx] =~ s/^\'?view\'?/'v'/i;
+ $attrs[$idx] =~ s/^\'?special\'?/'s'/i;
+ $attrs[$idx] =~ s/^\'?secondary\'?/'t'/i;
+ }
+ # Insure that the value is enclosed in single quotes.
+ $attrs[$idx] =~ s/^'?(\w+)'?$/'$1'/;
+ if ($attrs[$idx] =~ m/[,%]/) {
+ # contains a meta character.
+ push( @wh, q{( } . join ( " OR "
+ , map { m/\%/
+ ? qq{$flds[$idx] LIKE $_ }
+ : qq{$flds[$idx] = $_ }
+ } (split /,/, $attrs[$idx]) )
+ . q{ )}
+ );
+ }
+ else {
+ push( @wh, qq{$flds[$idx] = $attrs[$idx]} );
+ }
+ }
+ }
+
+ my $wh = ();
+ if (@wh) {
+ $wh = join( " AND ",'', @wh );
+ $tbl_sql = qq{
+ SELECT NULL::text AS "TABLE_CAT"
+ , $showschema AS "TABLE_SCHEM"
+ , c.relname AS "TABLE_NAME"
+ , CASE
+ WHEN c.relkind = 'r' THEN
+ CASE WHEN n.nspname ~ '^pg_' THEN 'SYSTEM TABLE' ELSE 'TABLE' END
+ WHEN c.relkind = 'v' THEN 'VIEW'
+ WHEN c.relkind = 'i' THEN 'INDEX'
+ WHEN c.relkind = 'S' THEN 'SEQUENCE'
+ WHEN c.relkind = 's' THEN 'SPECIAL'
+ WHEN c.relkind = 't' THEN 'SECONDARY'
+ ELSE 'UNKNOWN'
+ END AS "TABLE_TYPE"
+ , d.description AS "REMARKS"
+ FROM ${CATALOG}pg_class AS c
+ LEFT JOIN
+ ${CATALOG}pg_description AS d
+ ON (c.relfilenode = d.objoid AND d.objsubid = 0)
+ $schemajoin
+ WHERE
+ c.relname !~ '^xin[vx][0-9]+'
+ $wh
+ ORDER BY 2, 3
+ };
+ }
+ }
+ }
+
+ my $sth = $dbh->prepare( $tbl_sql ) or return undef;
+ $sth->execute();
+
+ return $sth;
+ }
+
+
+ sub tables {
+ my($dbh) = @_;
+ my $version = DBD::Pg::pg_server_version($dbh);
+ $version =~ /^(\d+\.\d+)/;
+ $version = $1;
+ my $SQL = ($version < 7.3) ?
+ "SELECT relname AS \"TABLE_NAME\"
+ FROM pg_class
+ WHERE relkind = 'r'
+ AND relname !~ '^pg_'
+ AND relname !~ '^xin[vx][0-9]+'
+ ORDER BY 1" :
+ "SELECT n.nspname AS \"SCHEMA_NAME\", c.relname AS \"TABLE_NAME\"
+ FROM pg_catalog.pg_class c
+ LEFT JOIN pg_catalog.pg_namespace n ON (n.oid = c.relnamespace)
+ WHERE c.relkind = 'r'
+ AND n.nspname NOT IN ('pg_catalog', 'pg_toast')
+ AND pg_catalog.pg_table_is_visible(c.oid)
+ ORDER BY 1,2";
+ my $sth = $dbh->prepare($SQL) or return undef;
+ $sth->execute or return undef;
+ my (@tables, @relname);
+ while (@relname = $sth->fetchrow_array) {
+ push @tables, $version < 7.3 ? $relname[0] : "$relname[0].$relname[1]";
+ }
+ $sth->finish;
+
+ return @tables;
+ }
+
+
+ sub table_attributes {
+ my ($dbh, $table) = @_;
+ my $CATALOG = DBD::Pg::pg_use_catalog($dbh);
+ my $result = [];
+ my $attrs = $dbh->selectall_arrayref(
+ "select a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull, a.atthasdef, a.attnum
+ from ${CATALOG}pg_attribute a,
+ ${CATALOG}pg_class c,
+ ${CATALOG}pg_type t
+ where c.relname = ?
+ and a.attrelid = c.oid
+ and a.attnum >= 0
+ and t.oid = a.atttypid
+ order by 1
+ ", undef, $table);
+
+ return $result unless scalar(@$attrs);
+
+ # Select the array value for tables primary key.
+ my $pk_key_sql = qq{SELECT pg_index.indkey
+ FROM ${CATALOG}pg_class, ${CATALOG}pg_index
+ WHERE
+ pg_class.oid = pg_index.indrelid
+ AND pg_class.relname = '$table'
+ AND pg_index.indisprimary = 't'
+ };
+ # Expand this (returned as a string) a real array.
+ my @pk = ();
+ my $pkeys = $dbh->selectrow_array( $pk_key_sql );
+ if (defined $pkeys) {
+ foreach (split( /\s+/, $pkeys))
+ {
+ push @pk, $_;
+ }
+ }
+ my $pk_bt =
+ (@pk) ? "AND pg_attribute.attnum in (" . join ( ", ", @pk ) . ")"
+ : "";
+
+ # Get the primary key
+ my $pri_key = $dbh->selectcol_arrayref("SELECT pg_attribute.attname
+ FROM ${CATALOG}pg_class, ${CATALOG}pg_attribute, ${CATALOG}pg_index
+ WHERE pg_class.oid = pg_attribute.attrelid
+ AND pg_class.oid = pg_index.indrelid
+ $pk_bt
+ AND pg_index.indisprimary = 't'
+ AND pg_class.relname = ?
+ ORDER BY pg_attribute.attnum
+ ", undef, $table );
+ $pri_key = [] unless $pri_key;
+
+ foreach my $attr (reverse @$attrs) {
+ my ($col_name, $col_type, $size, $mod, $notnull, $hasdef, $attnum) = @$attr;
+ my $col_size = do {
+ if ($size > 0) {
+ $size;
+ } elsif ($mod > 0xffff) {
+ my $prec = ($mod & 0xffff) - 4;
+ $mod >>= 16;
+ my $dig = $mod;
+ $dig;
+ } elsif ($mod >= 4) {
+ $mod - 4;
+ } else {
+ $mod;
+ }
+ };
+
+ # Get the default value, if any
+ my ($default) = $dbh->selectrow_array("SELECT adsrc FROM ${CATALOG}pg_attrdef WHERE adnum = $attnum") if -1 == $attnum;
+ $default = '' unless $default;
+
+ # Test for any constraints
+ # Note: as of PostgreSQL 7.3 pg_relcheck has been replaced
+ # by pg_constraint. To maintain compatibility, check
+ # version number and execute appropriate query.
+
+ my $version = pg_server_version( $dbh );
+
+ my $con_query = $version < 7.3
+ ? "SELECT rcsrc FROM pg_relcheck WHERE rcname = '${table}_$col_name'"
+ : "SELECT consrc FROM pg_catalog.pg_constraint WHERE contype = 'c' AND conname = '${table}_$col_name'";
+ my ($constraint) = $dbh->selectrow_array($con_query);
+ $constraint = '' unless $constraint;
+
+ # Check to see if this is the primary key
+ my $is_primary_key = scalar(grep { /^$col_name$/i } @$pri_key) ? 1 : 0;
+
+ push @$result,
+ { NAME => $col_name,
+ TYPE => $col_type,
+ SIZE => $col_size,
+ NOTNULL => $notnull,
+ DEFAULT => $default,
+ CONSTRAINT => $constraint,
+ PRIMARY_KEY => $is_primary_key,
+ };
+ }
+
+ return $result;
+ }
+
+
+ sub type_info_all {
+ my ($dbh) = @_;
+
+ #my $names = {
+ # TYPE_NAME => 0,
+ # DATA_TYPE => 1,
+ # PRECISION => 2,
+ # LITERAL_PREFIX => 3,
+ # LITERAL_SUFFIX => 4,
+ # CREATE_PARAMS => 5,
+ # NULLABLE => 6,
+ # CASE_SENSITIVE => 7,
+ # SEARCHABLE => 8,
+ # UNSIGNED_ATTRIBUTE => 9,
+ # MONEY =>10,
+ # AUTO_INCREMENT =>11,
+ # LOCAL_TYPE_NAME =>12,
+ # MINIMUM_SCALE =>13,
+ # MAXIMUM_SCALE =>14,
+ # };
+
+ my $names = {
+ TYPE_NAME => 0,
+ DATA_TYPE => 1,
+ COLUMN_SIZE => 2, # was PRECISION originally
+ LITERAL_PREFIX => 3,
+ LITERAL_SUFFIX => 4,
+ CREATE_PARAMS => 5,
+ NULLABLE => 6,
+ CASE_SENSITIVE => 7,
+ SEARCHABLE => 8,
+ UNSIGNED_ATTRIBUTE=> 9,
+ FIXED_PREC_SCALE => 10, # was MONEY originally
+ AUTO_UNIQUE_VALUE => 11, # was AUTO_INCREMENT originally
+ LOCAL_TYPE_NAME => 12,
+ MINIMUM_SCALE => 13,
+ MAXIMUM_SCALE => 14,
+ NUM_PREC_RADIX => 15,
+ };
+
+
+ # typname |typlen|typprtlen| SQL92
+ # --------------+------+---------+ -------
+ # bool | 1| 1| BOOLEAN
+ # text | -1| -1| like VARCHAR, but automatic storage allocation
+ # bpchar | -1| -1| CHARACTER(n) bp=blank padded
+ # varchar | -1| -1| VARCHAR(n)
+ # int2 | 2| 5| SMALLINT
+ # int4 | 4| 10| INTEGER
+ # int8 | 8| 20| /
+ # money | 4| 24| /
+ # float4 | 4| 12| FLOAT(p) for p<7=float4, for p<16=float8
+ # float8 | 8| 24| REAL
+ # abstime | 4| 20| /
+ # reltime | 4| 20| /
+ # tinterval | 12| 47| /
+ # date | 4| 10| /
+ # time | 8| 16| /
+ # datetime | 8| 47| /
+ # timespan | 12| 47| INTERVAL
+ # timestamp | 4| 19| TIMESTAMP
+ # --------------+------+---------+
+
+ # DBI type definitions / PostgreSQL definitions # type needs to be DBI-specific (not pg_type)
+ #
+ # SQL_ALL_TYPES 0
+ # SQL_CHAR 1 1042 bpchar
+ # SQL_NUMERIC 2 700 float4
+ # SQL_DECIMAL 3 700 float4
+ # SQL_INTEGER 4 23 int4
+ # SQL_SMALLINT 5 21 int2
+ # SQL_FLOAT 6 700 float4
+ # SQL_REAL 7 701 float8
+ # SQL_DOUBLE 8 20 int8
+ # SQL_DATE 9 1082 date
+ # SQL_TIME 10 1083 time
+ # SQL_TIMESTAMP 11 1296 timestamp
+ # SQL_VARCHAR 12 1043 varchar
+
+ my $ti = [
+ $names,
+ # name type prec prefix suffix create params null case se unsign mon incr local min max
+ #
+ [ 'bytea', -2, 4096, '\'', '\'', undef, 1, '1', 3, undef, '0', '0', 'BYTEA', undef, undef, undef ],
+ [ 'bool', 0, 1, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'BOOLEAN', undef, undef, undef ],
+ [ 'int8', 8, 20, undef, undef, undef, 1, '0', 2, '0', '0', '0', 'LONGINT', undef, undef, undef ],
+ [ 'int2', 5, 5, undef, undef, undef, 1, '0', 2, '0', '0', '0', 'SMALLINT', undef, undef, undef ],
+ [ 'int4', 4, 10, undef, undef, undef, 1, '0', 2, '0', '0', '0', 'INTEGER', undef, undef, undef ],
+ [ 'text', 12, 4096, '\'', '\'', undef, 1, '1', 3, undef, '0', '0', 'TEXT', undef, undef, undef ],
+ [ 'float4', 6, 12, undef, undef, 'precision', 1, '0', 2, '0', '0', '0', 'FLOAT', undef, undef, undef ],
+ [ 'float8', 7, 24, undef, undef, 'precision', 1, '0', 2, '0', '0', '0', 'REAL', undef, undef, undef ],
+ [ 'abstime', 10, 20, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'ABSTIME', undef, undef, undef ],
+ [ 'reltime', 10, 20, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'RELTIME', undef, undef, undef ],
+ [ 'tinterval', 11, 47, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'TINTERVAL', undef, undef, undef ],
+ [ 'money', 0, 24, undef, undef, undef, 1, '0', 2, undef, '1', '0', 'MONEY', undef, undef, undef ],
+ [ 'bpchar', 1, 4096, '\'', '\'', 'max length', 1, '1', 3, undef, '0', '0', 'CHARACTER', undef, undef, undef ],
+ [ 'bpchar', 12, 4096, '\'', '\'', 'max length', 1, '1', 3, undef, '0', '0', 'CHARACTER', undef, undef, undef ],
+ [ 'varchar', 12, 4096, '\'', '\'', 'max length', 1, '1', 3, undef, '0', '0', 'VARCHAR', undef, undef, undef ],
+ [ 'date', 9, 10, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'DATE', undef, undef, undef ],
+ [ 'time', 10, 16, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'TIME', undef, undef, undef ],
+ [ 'datetime', 11, 47, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'DATETIME', undef, undef, undef ],
+ [ 'timespan', 11, 47, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'INTERVAL', undef, undef, undef ],
+ [ 'timestamp', 10, 19, '\'', '\'', undef, 1, '0', 2, undef, '0', '0', 'TIMESTAMP', undef, undef, undef ]
+ #
+ # intentionally omitted: char, all geometric types, all array types
+ ];
+ return $ti;
+ }
+
+
+ # Characters that need to be escaped by quote().
+ my %esc = ( "'" => '\\047', # '\\' . sprintf("%03o", ord("'")), # ISO SQL 2
+ '\\' => '\\134', # '\\' . sprintf("%03o", ord("\\")),
+ );
+
+ # Set up lookup for SQL types we don't want to escape.
+ my %no_escape = map { $_ => 1 }
+ DBI::SQL_INTEGER, DBI::SQL_SMALLINT, DBI::SQL_DECIMAL,
+ DBI::SQL_FLOAT, DBI::SQL_REAL, DBI::SQL_DOUBLE, DBI::SQL_NUMERIC;
+
+ sub quote {
+ my ($dbh, $str, $data_type) = @_;
+ return "NULL" unless defined $str;
+ return $str if $data_type && $no_escape{$data_type};
+
+ $dbh->DBI::set_err(1, "Use of SQL_BINARY invalid in quote()")
+ if $data_type && $data_type == DBI::SQL_BINARY;
+
+ $str =~ s/(['\\\0])/$esc{$1}/g;
+ return "'$str'";
+ }
+
+} # end of package DBD::Pg::db
+
+{ package DBD::Pg::st; # ====== STATEMENT ======
+
+ # all done in XS
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBD::Pg - PostgreSQL database driver for the DBI module
+
+=head1 SYNOPSIS
+
+ use DBI;
+
+ $dbh = DBI->connect("dbi:Pg:dbname=$dbname", "", "");
+
+ # for some advanced uses you may need PostgreSQL type values:
+ use DBD::Oracle qw(:pg_types);
+
+ # See the DBI module documentation for full details
+
+=head1 DESCRIPTION
+
+DBD::Pg is a Perl module which works with the DBI module to provide access to
+PostgreSQL databases.
+
+=head1 MODULE DOCUMENTATION
+
+This documentation describes driver specific behavior and restrictions. It is
+not supposed to be used as the only reference for the user. In any case
+consult the DBI documentation first!
+
+=head1 THE DBI CLASS
+
+=head2 DBI Class Methods
+
+=over 4
+
+=item B<connect>
+
+To connect to a database with a minimum of parameters, use the following
+syntax:
+
+ $dbh = DBI->connect("dbi:Pg:dbname=$dbname", "", "");
+
+This connects to the database $dbname at localhost without any user
+authentication. This is sufficient for the defaults of PostgreSQL.
+
+The following connect statement shows all possible parameters:
+
+ $dbh = DBI->connect("dbi:Pg:dbname=$dbname;host=$host;port=$port;" .
+ "options=$options;tty=$tty", "$username", "$password");
+
+If a parameter is undefined PostgreSQL first looks for specific environment
+variables and then it uses hard coded defaults:
+
+ parameter environment variable hard coded default
+ --------------------------------------------------
+ dbname PGDATABASE current userid
+ host PGHOST localhost
+ port PGPORT 5432
+ options PGOPTIONS ""
+ tty PGTTY ""
+ username PGUSER current userid
+ password PGPASSWORD ""
+
+If a host is specified, the postmaster on this host needs to be started with
+the C<-i> option (TCP/IP sockets).
+
+The options parameter specifies runtime options for the Postgres
+backend. Common usage is to increase the number of buffers with the C<-B>
+option. Also important is the C<-F> option, which disables automatic fsync()
+call after each transaction. For further details please refer to the
+L<postgres>.
+
+For authentication with username and password appropriate entries have to be
+made in pg_hba.conf. Please refer to the L<pg_hba.conf> and the L<pg_passwd>
+for the different types of authentication. Note that for these two parameters
+DBI distinguishes between empty and undefined. If these parameters are
+undefined DBI substitutes the values of the environment variables DBI_USER and
+DBI_PASS if present.
+
+=item B<available_drivers>
+
+ @driver_names = DBI->available_drivers;
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<data_sources>
+
+ @data_sources = DBI->data_sources('Pg');
+
+The driver supports this method. Note that the necessary database connection to
+the database template1 will be done on the localhost without any
+user-authentication. Other preferences can only be set with the environment
+variables PGHOST, DBI_USER and DBI_PASS.
+
+=item B<trace>
+
+ DBI->trace($trace_level, $trace_file)
+
+Implemented by DBI, no driver-specific impact.
+
+=back
+
+=head2 DBI Dynamic Attributes
+
+See Common Methods.
+
+=head1 METHODS COMMON TO ALL HANDLES
+
+=over 4
+
+=item B<err>
+
+ $rv = $h->err;
+
+Supported by the driver as proposed by DBI. For the connect method it returns
+PQstatus. In all other cases it returns PQresultStatus of the current handle.
+
+=item B<errstr>
+
+ $str = $h->errstr;
+
+Supported by the driver as proposed by DBI. It returns the PQerrorMessage
+related to the current handle.
+
+=item B<state>
+
+ $str = $h->state;
+
+This driver does not (yet) support the state method.
+
+=item B<trace>
+
+ $h->trace($trace_level, $trace_filename);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<trace_msg>
+
+ $h->trace_msg($message_text);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<func>
+
+This driver supports a variety of driver specific functions accessible via the
+func interface:
+
+ $attrs = $dbh->func($table, 'table_attributes');
+
+This method returns for the given table a reference to an array of hashes:
+
+ NAME attribute name
+ TYPE attribute type
+ SIZE attribute size (-1 for variable size)
+ NULLABLE flag nullable
+ DEFAULT default value
+ CONSTRAINT constraint
+ PRIMARY_KEY flag is_primary_key
+
+ $lobjId = $dbh->func($mode, 'lo_creat');
+
+Creates a new large object and returns the object-id. $mode is a bit-mask
+describing different attributes of the new object. Use the following
+constants:
+
+ $dbh->{pg_INV_WRITE}
+ $dbh->{pg_INV_READ}
+
+Upon failure it returns undef.
+
+ $lobj_fd = $dbh->func($lobjId, $mode, 'lo_open');
+
+Opens an existing large object and returns an object-descriptor for use in
+subsequent lo_* calls. For the mode bits see lo_create. Returns undef upon
+failure. Note that 0 is a perfectly correct object descriptor!
+
+ $nbytes = $dbh->func($lobj_fd, $buf, $len, 'lo_write');
+
+Writes $len bytes of $buf into the large object $lobj_fd. Returns the number
+of bytes written and undef upon failure.
+
+ $nbytes = $dbh->func($lobj_fd, $buf, $len, 'lo_read');
+
+Reads $len bytes into $buf from large object $lobj_fd. Returns the number of
+bytes read and undef upon failure.
+
+ $loc = $dbh->func($lobj_fd, $offset, $whence, 'lo_lseek');
+
+Change the current read or write location on the large object
+$obj_id. Currently $whence can only be 0 (L_SET). Returns the current location
+and undef upon failure.
+
+ $loc = $dbh->func($lobj_fd, 'lo_tell');
+
+Returns the current read or write location on the large object $lobj_fd and
+undef upon failure.
+
+ $lobj_fd = $dbh->func($lobj_fd, 'lo_close');
+
+Closes an existing large object. Returns true upon success and false upon
+failure.
+
+ $lobj_fd = $dbh->func($lobj_fd, 'lo_unlink');
+
+Deletes an existing large object. Returns true upon success and false upon
+failure.
+
+ $lobjId = $dbh->func($filename, 'lo_import');
+
+Imports a Unix file as large object and returns the object id of the new
+object or undef upon failure.
+
+ $ret = $dbh->func($lobjId, 'lo_export', 'filename');
+
+Exports a large object into a Unix file. Returns false upon failure, true
+otherwise.
+
+ $ret = $dbh->func($line, 'putline');
+
+Used together with the SQL-command 'COPY table FROM STDIN' to copy large
+amount of data into a table avoiding the overhead of using single
+insert commands. The application must explicitly send the two characters "\."
+to indicate to the backend that it has finished sending its data. See test.pl
+for an example on how to use this function.
+
+ $ret = $dbh->func($buffer, length, 'getline');
+
+Used together with the SQL-command 'COPY table TO STDOUT' to dump a complete
+table. See test.pl for an example on how to use this function.
+
+ $ret = $dbh->func('pg_notifies');
+
+Returns either undef or a reference to two-element array [ $table,
+$backend_pid ] of asynchronous notifications received.
+
+ $fd = $dbh->func('getfd');
+
+Returns fd of the actual connection to server. Can be used with select() and
+func('pg_notifies').
+
+=back
+
+=head1 ATTRIBUTES COMMON TO ALL HANDLES
+
+=over 4
+
+=item B<Warn> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<Active> (boolean, read-only)
+
+Supported by the driver as proposed by DBI. A database handle is active while
+it is connected and statement handle is active until it is finished.
+
+=item B<Kids> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<ActiveKids> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<CachedKids> (hash ref)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<CompatMode> (boolean, inherited)
+
+Not used by this driver.
+
+=item B<InactiveDestroy> (boolean)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<PrintError> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<RaiseError> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<HandleError> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<ChopBlanks> (boolean, inherited)
+
+Supported by the driver as proposed by DBI. This method is similar to the
+SQL-function RTRIM.
+
+=item B<LongReadLen> (integer, inherited)
+
+Implemented by DBI, not used by the driver.
+
+=item B<LongTruncOk> (boolean, inherited)
+
+Implemented by DBI, not used by the driver.
+
+=item B<Taint> (boolean, inherited)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<private_*>
+
+Implemented by DBI, no driver-specific impact.
+
+=back
+
+=head1 DBI DATABASE HANDLE OBJECTS
+
+=head2 Database Handle Methods
+
+=over 4
+
+=item B<selectrow_array>
+
+ @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectrow_arrayref>
+
+ $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectrow_hashref>
+
+ $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectall_arrayref>
+
+ $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectall_hashref>
+
+ $hash_ref = $dbh->selectall_hashref($statement, $key_field);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<selectcol_arrayref>
+
+ $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<prepare>
+
+ $sth = $dbh->prepare($statement, \%attr);
+
+PostgreSQL does not have the concept of preparing a statement. Hence the
+prepare method just stores the statement after checking for place-holders. No
+information about the statement is available after preparing it.
+
+=item B<prepare_cached>
+
+ $sth = $dbh->prepare_cached($statement, \%attr);
+
+Implemented by DBI, no driver-specific impact. This method is not useful for
+this driver, because preparing a statement has no database interaction.
+
+=item B<do>
+
+ $rv = $dbh->do($statement, \%attr, @bind_values);
+
+Implemented by DBI, no driver-specific impact. See the notes for the execute
+method elsewhere in this document.
+
+=item B<commit>
+
+ $rc = $dbh->commit;
+
+Supported by the driver as proposed by DBI. See also the notes about
+B<Transactions> elsewhere in this document.
+
+=item B<rollback>
+
+ $rc = $dbh->rollback;
+
+Supported by the driver as proposed by DBI. See also the notes about
+B<Transactions> elsewhere in this document.
+
+=item B<disconnect>
+
+ $rc = $dbh->disconnect;
+
+Supported by the driver as proposed by DBI.
+
+=item B<ping>
+
+ $rc = $dbh->ping;
+
+This driver supports the ping-method, which can be used to check the validity
+of a database-handle. The ping method issues an empty query and checks the
+result status.
+
+=item B<table_info>
+
+ $sth = $dbh->table_info;
+
+Supported by the driver as proposed by DBI. This method returns all tables and
+views which are owned by the current user. It does not select any indexes and
+sequences. Also System tables are not selected. As TABLE_QUALIFIER the reltype
+attribute is returned and the REMARKS are undefined.
+
+=item B<foreign_key_info>
+
+ $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table,
+ $fk_catalog, $fk_schema, $fk_table );
+
+Supported by the driver as proposed by DBI. Unimplemented for Postgres
+servers before 7.3 (returns undef). Currently only returns information
+about first column of any multiple-column keys.
+
+=item B<tables>
+
+ @names = $dbh->tables;
+
+Supported by the driver as proposed by DBI. This method returns all tables and
+views which are owned by the current user. It does not select any indexes and
+sequences, or system tables.
+
+=item B<type_info_all>
+
+ $type_info_all = $dbh->type_info_all;
+
+Supported by the driver as proposed by DBI. Only for SQL data-types and for
+frequently used data-types information is provided. The mapping between the
+PostgreSQL typename and the SQL92 data-type (if possible) has been done
+according to the following table:
+
+ +---------------+------------------------------------+
+ | typname | SQL92 |
+ |---------------+------------------------------------|
+ | bool | BOOL |
+ | text | / |
+ | bpchar | CHAR(n) |
+ | varchar | VARCHAR(n) |
+ | int2 | SMALLINT |
+ | int4 | INT |
+ | int8 | / |
+ | money | / |
+ | float4 | FLOAT(p) p<7=float4, p<16=float8 |
+ | float8 | REAL |
+ | abstime | / |
+ | reltime | / |
+ | tinterval | / |
+ | date | / |
+ | time | / |
+ | datetime | / |
+ | timespan | TINTERVAL |
+ | timestamp | TIMESTAMP |
+ +---------------+------------------------------------+
+
+For further details concerning the PostgreSQL specific data-types please read
+the L<pgbuiltin>.
+
+=item B<type_info>
+
+ @type_info = $dbh->type_info($data_type);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<quote>
+
+ $sql = $dbh->quote($value, $data_type);
+
+This module implements its own quote method. In addition to the DBI method it
+also doubles the backslash, because PostgreSQL treats a backslash as an escape
+character.
+
+B<NOTE:> The undocumented (and invalid) support for the C<SQL_BINARY> data
+type is officially deprecated. Use C<PG_BYTEA> with C<bind_param()> instead:
+
+ $rv = $sth->bind_param($param_num, $bind_value,
+ { pg_type => DBD::Pg::PG_BYTEA });
+
+=back
+
+=head2 Database Handle Attributes
+
+=over 4
+
+=item B<AutoCommit> (boolean)
+
+Supported by the driver as proposed by DBI. According to the classification of
+DBI, PostgreSQL is a database, in which a transaction must be explicitly
+started. Without starting a transaction, every change to the database becomes
+immediately permanent. The default of AutoCommit is on, which corresponds to
+the default behavior of PostgreSQL. When setting AutoCommit to off, a
+transaction will be started and every commit or rollback will automatically
+start a new transaction. For details see the notes about B<Transactions>
+elsewhere in this document.
+
+=item B<Driver> (handle)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<Name> (string, read-only)
+
+The default method of DBI is overridden by a driver specific method, which
+returns only the database name. Anything else from the connection string is
+stripped off. Note, that here the method is read-only in contrast to the DBI
+specs.
+
+=item B<RowCacheSize> (integer)
+
+Implemented by DBI, not used by the driver.
+
+=item B<pg_auto_escape> (boolean)
+
+PostgreSQL specific attribute. If true, then quotes and backslashes in all
+parameters will be escaped in the following way:
+
+ escape quote with a quote (SQL)
+ escape backslash with a backslash
+
+The default is on. Note, that PostgreSQL also accepts quotes, which are
+escaped by a backslash. Any other ASCII character can be used directly in a
+string constant.
+
+=item B<pg_enable_utf8> (boolean)
+
+PostgreSQL specific attribute. If true, then the utf8 flag will be
+turned for returned character data (if the data is valid utf8). For
+details about the utf8 flag, see L<Encode>. This is only relevant under
+perl 5.8 and higher.
+
+B<NB>: This attribute is experimental and may be subject to change.
+
+=item B<pg_INV_READ> (integer, read-only)
+
+Constant to be used for the mode in lo_creat and lo_open.
+
+=item B<pg_INV_WRITE> (integer, read-only)
+
+Constant to be used for the mode in lo_creat and lo_open.
+
+=back
+
+=head1 DBI STATEMENT HANDLE OBJECTS
+
+=head2 Statement Handle Methods
+
+=over 4
+
+=item B<bind_param>
+
+ $rv = $sth->bind_param($param_num, $bind_value, \%attr);
+
+Supported by the driver as proposed by DBI.
+
+B<NOTE:> The undocumented (and invalid) support for the C<SQL_BINARY>
+SQL type is officially deprecated. Use C<PG_BYTEA> instead:
+
+ $rv = $sth->bind_param($param_num, $bind_value,
+ { pg_type => DBD::Pg::PG_BYTEA });
+
+=item B<bind_param_inout>
+
+Not supported by this driver.
+
+=item B<execute>
+
+ $rv = $sth->execute(@bind_values);
+
+Supported by the driver as proposed by DBI. In addition to 'UPDATE', 'DELETE',
+'INSERT' statements, for which it returns always the number of affected rows,
+the execute method can also be used for 'SELECT ... INTO table' statements.
+
+=item B<fetchrow_arrayref>
+
+ $ary_ref = $sth->fetchrow_arrayref;
+
+Supported by the driver as proposed by DBI.
+
+=item B<fetchrow_array>
+
+ @ary = $sth->fetchrow_array;
+
+Supported by the driver as proposed by DBI.
+
+=item B<fetchrow_hashref>
+
+ $hash_ref = $sth->fetchrow_hashref;
+
+Supported by the driver as proposed by DBI.
+
+=item B<fetchall_arrayref>
+
+ $tbl_ary_ref = $sth->fetchall_arrayref;
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<finish>
+
+ $rc = $sth->finish;
+
+Supported by the driver as proposed by DBI.
+
+=item B<rows>
+
+ $rv = $sth->rows;
+
+Supported by the driver as proposed by DBI. In contrast to many other drivers
+the number of rows is available immediately after executing the statement.
+
+=item B<bind_col>
+
+ $rc = $sth->bind_col($column_number, \$var_to_bind, \%attr);
+
+Supported by the driver as proposed by DBI.
+
+=item B<bind_columns>
+
+ $rc = $sth->bind_columns(\%attr, @list_of_refs_to_vars_to_bind);
+
+Supported by the driver as proposed by DBI.
+
+=item B<dump_results>
+
+ $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh);
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<blob_read>
+
+ $blob = $sth->blob_read($id, $offset, $len);
+
+Supported by this driver as proposed by DBI. Implemented by DBI but not
+documented, so this method might change.
+
+This method seems to be heavily influenced by the current implementation of
+blobs in Oracle. Nevertheless we try to be as compatible as possible. Whereas
+Oracle suffers from the limitation that blobs are related to tables and every
+table can have only one blob (data-type LONG), PostgreSQL handles its blobs
+independent of any table by using so called object identifiers. This explains
+why the blob_read method is blessed into the STATEMENT package and not part of
+the DATABASE package. Here the field parameter has been used to handle this
+object identifier. The offset and len parameter may be set to zero, in which
+case the driver fetches the whole blob at once.
+
+Starting with PostgreSQL-6.5 every access to a blob has to be put into a
+transaction. This holds even for a read-only access.
+
+See also the PostgreSQL-specific functions concerning blobs which are
+available via the func-interface.
+
+For further information and examples about blobs, please read the chapter
+about Large Objects in the PostgreSQL Programmer's Guide.
+
+=back
+
+=head2 Statement Handle Attributes
+
+=over 4
+
+=item B<NUM_OF_FIELDS> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NUM_OF_PARAMS> (integer, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME> (array-ref, read-only)
+
+Supported by the driver as proposed by DBI.
+
+=item B<NAME_lc> (array-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<NAME_uc> (array-ref, read-only)
+
+Implemented by DBI, no driver-specific impact.
+
+=item B<TYPE> (array-ref, read-only)
+
+Supported by the driver as proposed by DBI, with the restriction, that the
+types are PostgreSQL specific data-types which do not correspond to
+international standards.
+
+=item B<PRECISION> (array-ref, read-only)
+
+Not supported by the driver.
+
+=item B<SCALE> (array-ref, read-only)
+
+Not supported by the driver.
+
+=item B<NULLABLE> (array-ref, read-only)
+
+Not supported by the driver.
+
+=item B<CursorName> (string, read-only)
+
+Not supported by the driver. See the note about B<Cursors> elsewhere in this
+document.
+
+=item B<Statement> (string, read-only)
+
+Supported by the driver as proposed by DBI.
+
+=item B<RowCache> (integer, read-only)
+
+Not supported by the driver.
+
+=item B<pg_size> (array-ref, read-only)
+
+PostgreSQL specific attribute. It returns a reference to an array of integer
+values for each column. The integer shows the size of the column in
+bytes. Variable length columns are indicated by -1.
+
+=item B<pg_type> (hash-ref, read-only)
+
+PostgreSQL specific attribute. It returns a reference to an array of strings
+for each column. The string shows the name of the data_type.
+
+=item B<pg_oid_status> (integer, read-only)
+
+PostgreSQL specific attribute. It returns the OID of the last INSERT command.
+
+=item B<pg_cmd_status> (integer, read-only)
+
+PostgreSQL specific attribute. It returns the type of the last
+command. Possible types are: INSERT, DELETE, UPDATE, SELECT.
+
+=back
+
+=head1 FURTHER INFORMATION
+
+=head2 Transactions
+
+The transaction behavior is now controlled with the attribute AutoCommit. For
+a complete definition of AutoCommit please refer to the DBI documentation.
+
+According to the DBI specification the default for AutoCommit is TRUE. In this
+mode, any change to the database becomes valid immediately. Any 'begin',
+'commit' or 'rollback' statement will be rejected.
+
+If AutoCommit is switched-off, immediately a transaction will be started by
+issuing a 'begin' statement. Any 'commit' or 'rollback' will start a new
+transaction. A disconnect will issue a 'rollback' statement.
+
+=head2 Large Objects
+
+The driver supports all large-objects related functions provided by libpq via
+the func-interface. Please note, that starting with PostgreSQL 6.5 any access
+to a large object - even read-only - has to be put into a transaction!
+
+=head2 Cursors
+
+Although PostgreSQL has a cursor concept, it has not been used in the current
+implementation. Cursors in PostgreSQL can only be used inside a transaction
+block. Because only one transaction block at a time is allowed, this would
+have implied the restriction, not to use any nested SELECT statements. Hence
+the execute method fetches all data at once into data structures located in
+the frontend application. This has to be considered when selecting large
+amounts of data!
+
+=head2 Data-Type bool
+
+The current implementation of PostgreSQL returns 't' for true and 'f' for
+false. From the Perl point of view a rather unfortunate choice. The DBD::Pg
+module translates the result for the data-type bool in a perl-ish like manner:
+'f' -> '0' and 't' -> '1'. This way the application does not have to check the
+database-specific returned values for the data-type bool, because Perl treats
+'0' as false and '1' as true.
+
+Boolean values can be passed to PostgreSQL as TRUE, 't', 'true', 'y', 'yes' or
+'1' for true and FALSE, 'f', 'false', 'n', 'no' or '0' for false.
+
+=head2 Schema support
+
+PostgreSQL version 7.3 introduced schema support. Note that the PostgreSQL
+schema concept may differ to that of other databases. Please refer to the
+PostgreSQL documentation for more details.
+
+Currently DBD::Pg does not provide explicit support for PostgreSQL schemas.
+However, schema functionality may be used without any restrictions by
+explicitly addressing schema objects, e.g.
+
+ my $res = $dbh->selectall_arrayref("SELECT * FROM my_schema.my_table");
+
+or by manipulating the schema search path with SET search_path, e.g.
+
+ $dbh->do("SET search_path TO my_schema, public");
+
+B<NOTE:> If you create an object with the same name as a PostgreSQL system
+object (as contained in the pg_catalog schema) and explicitly set the search
+path so that pg_catalog comes after the new object's schema, some DBD::Pg
+methods (particularly those querying PostgreSQL system objects) may fail.
+This problem should be fixed in a future release of DBD::Pg. Creating objects
+with the same name as system objects (or beginning with 'pg_') is not
+recommended practice and should be avoided in any case.
+
+=head1 SEE ALSO
+
+L<DBI>
+
+=head1 AUTHORS
+
+DBI and DBD-Oracle by Tim Bunce (Tim.Bunce@ig.co.uk)
+
+DBD-Pg by Edmund Mergl (E.Mergl@bawue.de) and Jeffrey W. Baker
+(jwbaker@acm.org). By David Wheeler <david@wheeler.net>, Jason
+Stewart <jason@openinformatics.com> and Bruce Momjian
+<pgman@candle.pha.pa.us> after v1.13.
+
+Major parts of this package have been copied from DBI and DBD-Oracle.
+
+=head1 COPYRIGHT
+
+The DBD::Pg module is free software. You may distribute under the terms of
+either the GNU General Public License or the Artistic License, as specified in
+the Perl README file.
+
+=head1 ACKNOWLEDGMENTS
+
+See also B<DBI/ACKNOWLEDGMENTS>.
+
+=cut
+
--- /dev/null
+/*
+ $Id: Pg.xs,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+ Copyright (c) 1997,1998,1999,2000 Edmund Mergl
+ Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the Perl README file.
+
+*/
+
+
+#include "Pg.h"
+
+
+#ifdef _MSC_VER
+#define strncasecmp(a,b,c) _strnicmp((a),(b),(c))
+#endif
+
+
+
+DBISTATE_DECLARE;
+
+
+MODULE = DBD::Pg PACKAGE = DBD::Pg
+
+I32
+constant(name=Nullch)
+ char *name
+ PROTOTYPE:
+ ALIAS:
+ PG_BOOL = 16
+ PG_BYTEA = 17
+ PG_CHAR = 18
+ PG_INT8 = 20
+ PG_INT2 = 21
+ PG_INT4 = 23
+ PG_TEXT = 25
+ PG_OID = 26
+ PG_FLOAT4 = 700
+ PG_FLOAT8 = 701
+ PG_ABSTIME = 702
+ PG_RELTIME = 703
+ PG_TINTERVAL = 704
+ PG_BPCHAR = 1042
+ PG_VARCHAR = 1043
+ PG_DATE = 1082
+ PG_TIME = 1083
+ PG_DATETIME = 1184
+ PG_TIMESPAN = 1186
+ PG_TIMESTAMP = 1296
+ CODE:
+ if (!ix) {
+ if (!name) name = GvNAME(CvGV(cv));
+ croak("Unknown DBD::Pg constant '%s'", name);
+ }
+ else RETVAL = ix;
+ OUTPUT:
+ RETVAL
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ items = 0; /* avoid 'unused variable' warning */
+ DBISTATE_INIT;
+ /* XXX this interface will change: */
+ DBI_IMP_SIZE("DBD::Pg::dr::imp_data_size", sizeof(imp_drh_t));
+ DBI_IMP_SIZE("DBD::Pg::db::imp_data_size", sizeof(imp_dbh_t));
+ DBI_IMP_SIZE("DBD::Pg::st::imp_data_size", sizeof(imp_sth_t));
+ dbd_init(DBIS);
+
+
+# ------------------------------------------------------------
+# driver level interface
+# ------------------------------------------------------------
+MODULE = DBD::Pg PACKAGE = DBD::Pg::dr
+
+# disconnect_all renamed and ALIASed to avoid length clash on VMS :-(
+void
+discon_all_(drh)
+ SV * drh
+ ALIAS:
+ disconnect_all = 1
+ CODE:
+ D_imp_drh(drh);
+ ST(0) = dbd_discon_all(drh, imp_drh) ? &sv_yes : &sv_no;
+
+
+
+# ------------------------------------------------------------
+# database level interface
+# ------------------------------------------------------------
+MODULE = DBD::Pg PACKAGE = DBD::Pg::db
+
+void
+_login(dbh, dbname, username, pwd)
+ SV * dbh
+ char * dbname
+ char * username
+ char * pwd
+ CODE:
+ D_imp_dbh(dbh);
+ ST(0) = pg_db_login(dbh, imp_dbh, dbname, username, pwd) ? &sv_yes : &sv_no;
+
+
+int
+_ping(dbh)
+ SV * dbh
+ CODE:
+ int ret;
+ ret = dbd_db_ping(dbh);
+ if (ret == 0) {
+ XST_mUNDEF(0);
+ }
+ else {
+ XST_mIV(0, ret);
+ }
+
+void
+getfd(dbh)
+ SV * dbh
+ CODE:
+ int ret;
+ D_imp_dbh(dbh);
+
+ ret = dbd_db_getfd(dbh, imp_dbh);
+ ST(0) = sv_2mortal( newSViv( ret ) );
+
+void
+pg_notifies(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+
+ ST(0) = dbd_db_pg_notifies(dbh, imp_dbh);
+
+void
+commit(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) {
+ warn("commit ineffective with AutoCommit enabled");
+ }
+ ST(0) = dbd_db_commit(dbh, imp_dbh) ? &sv_yes : &sv_no;
+
+
+void
+rollback(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ if (DBIc_has(imp_dbh, DBIcf_AutoCommit)) {
+ warn("rollback ineffective with AutoCommit enabled");
+ }
+ ST(0) = dbd_db_rollback(dbh, imp_dbh) ? &sv_yes : &sv_no;
+
+
+void
+disconnect(dbh)
+ SV * dbh
+ CODE:
+ D_imp_dbh(dbh);
+ if ( !DBIc_ACTIVE(imp_dbh) ) {
+ XSRETURN_YES;
+ }
+ /* pre-disconnect checks and tidy-ups */
+ if (DBIc_CACHED_KIDS(imp_dbh)) {
+ SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh));
+ DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
+ }
+ /* Check for disconnect() being called whilst refs to cursors */
+ /* still exists. This possibly needs some more thought. */
+ if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !dirty) {
+ char *plural = (DBIc_ACTIVE_KIDS(imp_dbh)==1) ? "" : "s";
+ warn("disconnect(%s) invalidates %d active statement%s. %s",
+ SvPV(dbh,na), (int)DBIc_ACTIVE_KIDS(imp_dbh), plural,
+ "Either destroy statement handles or call finish on them before disconnecting.");
+ }
+ ST(0) = dbd_db_disconnect(dbh, imp_dbh) ? &sv_yes : &sv_no;
+
+
+void
+STORE(dbh, keysv, valuesv)
+ SV * dbh
+ SV * keysv
+ SV * valuesv
+ CODE:
+ D_imp_dbh(dbh);
+ ST(0) = &sv_yes;
+ if (!dbd_db_STORE_attrib(dbh, imp_dbh, keysv, valuesv)) {
+ if (!DBIS->set_attr(dbh, keysv, valuesv)) {
+ ST(0) = &sv_no;
+ }
+ }
+
+
+void
+FETCH(dbh, keysv)
+ SV * dbh
+ SV * keysv
+ CODE:
+ D_imp_dbh(dbh);
+ SV *valuesv = dbd_db_FETCH_attrib(dbh, imp_dbh, keysv);
+ if (!valuesv) {
+ valuesv = DBIS->get_attr(dbh, keysv);
+ }
+ ST(0) = valuesv; /* dbd_db_FETCH_attrib did sv_2mortal */
+
+
+void
+DESTROY(dbh)
+ SV * dbh
+ PPCODE:
+ D_imp_dbh(dbh);
+ ST(0) = &sv_yes;
+ if (!DBIc_IMPSET(imp_dbh)) { /* was never fully set up */
+ if (DBIc_WARN(imp_dbh) && !dirty && dbis->debug >= 2) {
+ warn("Database handle %s DESTROY ignored - never set up", SvPV(dbh,na));
+ }
+ }
+ else {
+ /* pre-disconnect checks and tidy-ups */
+ if (DBIc_CACHED_KIDS(imp_dbh)) {
+ SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh));
+ DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
+ }
+ if (DBIc_IADESTROY(imp_dbh)) { /* want's ineffective destroy */
+ DBIc_ACTIVE_off(imp_dbh);
+ }
+ if (DBIc_ACTIVE(imp_dbh)) {
+ if (DBIc_WARN(imp_dbh) && (!dirty || dbis->debug >= 3)) {
+ warn("Database handle destroyed without explicit disconnect");
+ }
+ /* The application has not explicitly disconnected. That's bad. */
+ /* To ensure integrity we *must* issue a rollback. This will be */
+ /* harmless if the application has issued a commit. If it hasn't */
+ /* then it'll ensure integrity. Consider a Ctrl-C killing perl */
+ /* between two statements that must be executed as a transaction. */
+ /* Perl will call DESTROY on the dbh and, if we don't rollback, */
+ /* the server will automatically commit! Bham! Corrupt database! */
+ if (!DBIc_has(imp_dbh,DBIcf_AutoCommit)) {
+ dbd_db_rollback(dbh, imp_dbh); /* ROLLBACK! */
+ }
+ dbd_db_disconnect(dbh, imp_dbh);
+ }
+ dbd_db_destroy(dbh, imp_dbh);
+ }
+
+
+# driver specific functions
+
+
+void
+lo_open(dbh, lobjId, mode)
+ SV * dbh
+ unsigned int lobjId
+ int mode
+ CODE:
+ int ret = pg_db_lo_open(dbh, lobjId, mode);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+void
+lo_close(dbh, fd)
+ SV * dbh
+ int fd
+ CODE:
+ ST(0) = (-1 != pg_db_lo_close(dbh, fd)) ? &sv_yes : &sv_no;
+
+
+void
+lo_read(dbh, fd, buf, len)
+ SV * dbh
+ int fd
+ char * buf
+ int len
+ PREINIT:
+ SV *bufsv = SvROK(ST(2)) ? SvRV(ST(2)) : ST(2);
+ int ret;
+ CODE:
+ buf = SvGROW(bufsv, len + 1);
+ ret = pg_db_lo_read(dbh, fd, buf, len);
+ if (ret > 0) {
+ SvCUR_set(bufsv, ret);
+ *SvEND(bufsv) = '\0';
+ sv_setpvn(ST(2), buf, ret);
+ SvSETMAGIC(ST(2));
+ }
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_write(dbh, fd, buf, len)
+ SV * dbh
+ int fd
+ char * buf
+ int len
+ CODE:
+ int ret = pg_db_lo_write(dbh, fd, buf, len);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_lseek(dbh, fd, offset, whence)
+ SV * dbh
+ int fd
+ int offset
+ int whence
+ CODE:
+ int ret = pg_db_lo_lseek(dbh, fd, offset, whence);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_creat(dbh, mode)
+ SV * dbh
+ int mode
+ CODE:
+ int ret = pg_db_lo_creat(dbh, mode);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_tell(dbh, fd)
+ SV * dbh
+ int fd
+ CODE:
+ int ret = pg_db_lo_tell(dbh, fd);
+ ST(0) = (-1 != ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_unlink(dbh, lobjId)
+ SV * dbh
+ unsigned int lobjId
+ CODE:
+ ST(0) = (-1 != pg_db_lo_unlink(dbh, lobjId)) ? &sv_yes : &sv_no;
+
+
+void
+lo_import(dbh, filename)
+ SV * dbh
+ char * filename
+ CODE:
+ unsigned int ret = pg_db_lo_import(dbh, filename);
+ ST(0) = (ret) ? sv_2mortal(newSViv(ret)) : &sv_undef;
+
+
+void
+lo_export(dbh, lobjId, filename)
+ SV * dbh
+ unsigned int lobjId
+ char * filename
+ CODE:
+ ST(0) = (-1 != pg_db_lo_export(dbh, lobjId, filename)) ? &sv_yes : &sv_no;
+
+
+void
+putline(dbh, buf)
+ SV * dbh
+ char * buf
+ CODE:
+ int ret = pg_db_putline(dbh, buf);
+ ST(0) = (-1 != ret) ? &sv_yes : &sv_no;
+
+
+void
+getline(dbh, buf, len)
+ PREINIT:
+ SV *bufsv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
+ INPUT:
+ SV * dbh
+ int len
+ char * buf = sv_grow(bufsv, len);
+ CODE:
+ int ret = pg_db_getline(dbh, buf, len);
+ if (*buf == '\\' && *(buf+1) == '.') {
+ ret = -1;
+ }
+ sv_setpv((SV*)ST(1), buf);
+ SvSETMAGIC(ST(1));
+ ST(0) = (-1 != ret) ? &sv_yes : &sv_no;
+
+
+void
+endcopy(dbh)
+ SV * dbh
+ CODE:
+ ST(0) = (-1 != pg_db_endcopy(dbh)) ? &sv_yes : &sv_no;
+
+
+# -- end of DBD::Pg::db
+
+
+# ------------------------------------------------------------
+# statement interface
+# ------------------------------------------------------------
+MODULE = DBD::Pg PACKAGE = DBD::Pg::st
+
+void
+_prepare(sth, statement, attribs=Nullsv)
+ SV * sth
+ char * statement
+ SV * attribs
+ CODE:
+ {
+ D_imp_sth(sth);
+ D_imp_dbh_from_sth;
+ DBD_ATTRIBS_CHECK("_prepare", sth, attribs);
+ if (!strncasecmp(statement, "begin", 5) ||
+ !strncasecmp(statement, "end", 4) ||
+ !strncasecmp(statement, "commit", 6) ||
+ !strncasecmp(statement, "abort", 5) ||
+ !strncasecmp(statement, "rollback", 8) ) {
+ warn("please use DBI functions for transaction handling");
+ ST(0) = &sv_no;
+ } else {
+ ST(0) = dbd_st_prepare(sth, imp_sth, statement, attribs) ? &sv_yes : &sv_no;
+ }
+ }
+
+
+void
+rows(sth)
+ SV * sth
+ CODE:
+ D_imp_sth(sth);
+ XST_mIV(0, dbd_st_rows(sth, imp_sth));
+
+
+void
+bind_param(sth, param, value, attribs=Nullsv)
+ SV * sth
+ SV * param
+ SV * value
+ SV * attribs
+ CODE:
+ {
+ IV sql_type = 0;
+ D_imp_sth(sth);
+ if (attribs) {
+ if (SvNIOK(attribs)) {
+ sql_type = SvIV(attribs);
+ attribs = Nullsv;
+ }
+ else {
+ SV **svp;
+ DBD_ATTRIBS_CHECK("bind_param", sth, attribs);
+ /* XXX we should perhaps complain if TYPE is not SvNIOK */
+ DBD_ATTRIB_GET_IV(attribs, "TYPE", 4, svp, sql_type);
+ }
+ }
+ ST(0) = dbd_bind_ph(sth, imp_sth, param, value, sql_type, attribs, FALSE, 0) ? &sv_yes : &sv_no;
+ }
+
+
+void
+bind_param_inout(sth, param, value_ref, maxlen, attribs=Nullsv)
+ SV * sth
+ SV * param
+ SV * value_ref
+ IV maxlen
+ SV * attribs
+ CODE:
+ {
+ IV sql_type = 0;
+ D_imp_sth(sth);
+ if (!SvROK(value_ref) || SvTYPE(SvRV(value_ref)) > SVt_PVMG) {
+ croak("bind_param_inout needs a reference to a scalar value");
+ }
+ if (SvREADONLY(SvRV(value_ref))) {
+ croak(no_modify);
+ }
+ if (attribs) {
+ if (SvNIOK(attribs)) {
+ sql_type = SvIV(attribs);
+ attribs = Nullsv;
+ }
+ else {
+ SV **svp;
+ DBD_ATTRIBS_CHECK("bind_param", sth, attribs);
+ DBD_ATTRIB_GET_IV(attribs, "TYPE", 4, svp, sql_type);
+ }
+ }
+ ST(0) = dbd_bind_ph(sth, imp_sth, param, SvRV(value_ref), sql_type, attribs, TRUE, maxlen) ? &sv_yes : &sv_no;
+ }
+
+
+void
+execute(sth, ...)
+ SV * sth
+ CODE:
+ D_imp_sth(sth);
+ int ret;
+ if (items > 1) {
+ /* Handle binding supplied values to placeholders */
+ int i;
+ SV *idx;
+ imp_sth->all_params_len = 0; /* used for malloc of statement string in case we have placeholders */
+ if (items-1 != DBIc_NUM_PARAMS(imp_sth)) {
+ croak("execute called with %ld bind variables, %d needed", items-1, DBIc_NUM_PARAMS(imp_sth));
+ XSRETURN_UNDEF;
+ }
+ idx = sv_2mortal(newSViv(0));
+ for(i=1; i < items ; ++i) {
+ sv_setiv(idx, i);
+ if (!dbd_bind_ph(sth, imp_sth, idx, ST(i), 0, Nullsv, FALSE, 0)) {
+ XSRETURN_UNDEF; /* dbd_bind_ph already registered error */
+ }
+ }
+ }
+ ret = dbd_st_execute(sth, imp_sth);
+ /* remember that dbd_st_execute must return <= -2 for error */
+ if (ret == 0) { /* ok with no rows affected */
+ XST_mPV(0, "0E0"); /* (true but zero) */
+ }
+ else if (ret < -1) { /* -1 == unknown number of rows */
+ XST_mUNDEF(0); /* <= -2 means error */
+ }
+ else {
+ XST_mIV(0, ret); /* typically 1, rowcount or -1 */
+ }
+
+
+void
+fetchrow_arrayref(sth)
+ SV * sth
+ ALIAS:
+ fetch = 1
+ CODE:
+ D_imp_sth(sth);
+ AV *av = dbd_st_fetch(sth, imp_sth);
+ ST(0) = (av) ? sv_2mortal(newRV_inc((SV *)av)) : &sv_undef;
+
+
+void
+fetchrow_array(sth)
+ SV * sth
+ ALIAS:
+ fetchrow = 1
+ PPCODE:
+ D_imp_sth(sth);
+ AV *av;
+ av = dbd_st_fetch(sth, imp_sth);
+ if (av) {
+ int num_fields = AvFILL(av)+1;
+ int i;
+ EXTEND(sp, num_fields);
+ for(i=0; i < num_fields; ++i) {
+ PUSHs(AvARRAY(av)[i]);
+ }
+ }
+
+
+void
+finish(sth)
+ SV * sth
+ CODE:
+ D_imp_sth(sth);
+ D_imp_dbh_from_sth;
+ if (!DBIc_ACTIVE(imp_dbh)) {
+ /* Either an explicit disconnect() or global destruction */
+ /* has disconnected us from the database. Finish is meaningless */
+ /* XXX warn */
+ XSRETURN_YES;
+ }
+ if (!DBIc_ACTIVE(imp_sth)) {
+ /* No active statement to finish */
+ XSRETURN_YES;
+ }
+ ST(0) = dbd_st_finish(sth, imp_sth) ? &sv_yes : &sv_no;
+
+
+void
+blob_read(sth, field, offset, len, destrv=Nullsv, destoffset=0)
+ SV * sth
+ int field
+ long offset
+ long len
+ SV * destrv
+ long destoffset
+ CODE:
+ {
+ D_imp_sth(sth);
+ if (!destrv) {
+ destrv = sv_2mortal(newRV_inc(sv_2mortal(newSViv(0))));
+ }
+ ST(0) = dbd_st_blob_read(sth, imp_sth, field, offset, len, destrv, destoffset) ? SvRV(destrv) : &sv_undef;
+ }
+
+void
+STORE(sth, keysv, valuesv)
+ SV * sth
+ SV * keysv
+ SV * valuesv
+ CODE:
+ D_imp_sth(sth);
+ ST(0) = &sv_yes;
+ if (!dbd_st_STORE_attrib(sth, imp_sth, keysv, valuesv)) {
+ if (!DBIS->set_attr(sth, keysv, valuesv)) {
+ ST(0) = &sv_no;
+ }
+ }
+
+
+# FETCH renamed and ALIASed to avoid case clash on VMS :-(
+void
+FETCH_attrib(sth, keysv)
+ SV * sth
+ SV * keysv
+ ALIAS:
+ FETCH = 1
+ CODE:
+ D_imp_sth(sth);
+ SV *valuesv = dbd_st_FETCH_attrib(sth, imp_sth, keysv);
+ if (!valuesv) {
+ valuesv = DBIS->get_attr(sth, keysv);
+ }
+ ST(0) = valuesv; /* dbd_st_FETCH_attrib did sv_2mortal */
+
+
+void
+DESTROY(sth)
+ SV * sth
+ PPCODE:
+ D_imp_sth(sth);
+ ST(0) = &sv_yes;
+ if (!DBIc_IMPSET(imp_sth)) { /* was never fully set up */
+ if (DBIc_WARN(imp_sth) && !dirty && dbis->debug >= 2) {
+ warn("Statement handle %s DESTROY ignored - never set up", SvPV(sth,na));
+ }
+ }
+ else {
+ if (DBIc_IADESTROY(imp_sth)) { /* want's ineffective destroy */
+ DBIc_ACTIVE_off(imp_sth);
+ }
+ if (DBIc_ACTIVE(imp_sth)) {
+ dbd_st_finish(sth, imp_sth);
+ }
+ dbd_st_destroy(sth, imp_sth);
+ }
+
+
+# end of Pg.xs
--- /dev/null
+
+DBD::Pg -- the DBI PostgreSQL interface for Perl
+
+# $Id: README,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+DESCRIPTION:
+------------
+
+This is version 1.21 of DBD-Pg. The web site for this interface is at:
+
+ http://gborg.postgresql.org/project/dbdpg/projdisplay.php
+
+For further information about DBI look at:
+
+ http://dbi.perl.org/
+
+For information about PostgreSQL, visit:
+
+ http://www.postgresql.org/
+
+COPYRIGHT:
+----------
+
+ Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
+ Copyright (c) 1997,1998,1999,2000 Edmund Mergl
+ Copyright (c) 2002 Jeffrey W. Baker
+ Copyright (c) 2002 PostgreSQL Global Development Group
+
+You may distribute under the terms of either the GNU General Public
+License or the Artistic License, as specified in the Perl README file.
+
+
+HOW TO GET THE LATEST VERSION:
+------------------------------
+
+Use the following URL to look for new versions of this module:
+
+ http://gborg.postgresql.org/project/dbdpg/projdisplay.php
+
+or
+
+ http://www.perl.com/CPAN/modules/by-module/DBD/
+
+Note, that this request will be redirected automatically to the
+nearest CPAN site.
+
+
+IF YOU HAVE PROBLEMS:
+---------------------
+
+Please send comments and bug-reports to <dbd-general@gborg.postgresql.org>
+
+Please include the output of perl -v and perl -V, the version of PostgreSQL,
+the version of DBD-Pg, the version of DBI, and details about your platform
+in your bug-report.
+
+
+REQUIREMENTS:
+-------------
+
+ build, test, and install Perl 5 (at least 5.005)
+ build, test, and install the DBI module (at least 1.30)
+ build, test, and install PostgreSQL (at least 7.3)
+ build, test, and install Test::Simple (at least 0.17)
+
+INSTALLATION:
+-------------
+
+By default Makefile.PL uses App:Info to find the location of the
+PostgreSQL library and include directories. However, if you want to
+control it yourself, define the environment variables POSTGRES_INCLUDE
+and POSTGRES_LIB, or POSTGRES_HOME.
+
+ 1. perl Makefile.PL
+ 2. make
+ 3. make test
+ 4. make install
+
+Do steps 1 to 3 as normal user, not as root!
+
+
+TESTING:
+--------
+
+The tests are designed to connect to a live database. The following
+environment variables must be set for the tests to run:
+
+ DBI_DSN=dbi:Pg:dbname=<database>
+ DBI_USER=<username>
+ DBI_PASS=<password>
+
+If you are using the shared library libpq.so check if your dynamic
+loader finds libpq.so. With Linux the command /sbin/ldconfig -v should
+tell you, where it finds libpq.so. If ldconfig does not find libpq.so,
+either add an appropriate entry to /etc/ld.so.conf and re-run ldconfig
+or add the path to the environment variable LD_LIBRARY_PATH.
+
+A typical error message resulting from not finding libpq.so is:
+
+ install_driver(Pg) failed: Can't load './blib/arch/auto/DBD/Pg/Pg.so'
+ for module DBD::Pg: File not found at
+
+If you get an error message like:
+
+ perl: error while loading shared libraries:
+ /usr/lib/perl5/site_perl/5.6.0/i386-linux/auto/DBD/Pg/Pg.so: undefined
+ symbol: PQconnectdb
+
+when you call DBI->connect, then your libpq.so was probably not seen at
+build-time. This should have caused 'make test' to fail; did you really
+run it and look at the output? Check the setting of POSTGRES_LIB and
+recompile DBD-Pg.
+
+Some linux distributions have incomplete perl installations. If you have
+compile errors like "XS_VERSION_BOOTCHECK undeclared", do:
+
+ find .../lib/perl5 -name XSUB.h -print
+
+If this file is not present, you need to recompile and re-install perl.
+
+SGI users: if you get segmentation faults make sure, you use the malloc
+which comes with perl when compiling perl (the default is not to).
+"David R. Noble" <drnoble@engsci.sandia.gov>
+
+HP users: if you get error messages like:
+
+ can't open shared library: .../lib/libpq.sl
+ No such file or directory
+
+when running the test script, try to replace the 'shared' option in the
+LDDFLAGS with 'archive'. Dan Lauterbach <danla@dimensional.com>
+
+
+FreeBSD users: if you get during make test the error message:
+
+ 'DBD driver has not implemented the AutoCommit attribute'
+
+recompile the DBI module and the DBD-Pg module and disable optimization.
+This error message is due to the broken optimization in gcc-2.7.2.1.
+
+If you get compiler errors like:
+ In function `XS_DBD__Pg__dr_discon_all_'
+ `sv_yes' undeclared (first use in this function)
+
+It may be because there is a 'patchlevel.h' file from another package
+(such as 'hdf') in your POSTGRES_INCLUDE dir. The presence of this file
+prevents the compiler from finding the perl include file
+'mach/CORE/patchlevel.h'. Do 'pg_config --includedir' to identify the
+POSTGRES_INCLUDE dir. Rename patchlevel.h whilst you build DBD::Pg.
+
+
+Sun Users: if you get compile errors like:
+
+ /usr/include/string.h:57: parse error before `]'
+
+then you need to remove from pgsql/include/libpq-fe.h the define for
+strerror, which clashes with the definition in the standard include
+file.
+
+Win32 Users: Running DBD-Pg scripts on Win32 needs some configuration work
+on the server side:
+
+ o add a postgres user with the same name as the NT-User
+ (eg Administrator)
+ o make sure, that your pg_hba.conf on the server is configured,
+ such that a connection from another host will be accepted
--- /dev/null
+
+$Id: README.win32,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+
+Here is a step-by-step procedure for getting DBD-Pg to work on Windows
+NT. This Port has been done by Bob Kline <bkline@rksystems.com>.
+
+
+prerequisites: (older versions might also work, but these are the
+-------------- versions I used)
+
+ o Windows NT4 SP4
+ o Visual Studio 6.0
+ o ActivePerl-5_6_0_613 with DBI-1.13
+ o postgresql-7.0.2
+ o DBD-Pg-0.95
+
+Here we assume, that perl and postgresql have been installed in C:\. Now
+perform the following steps:
+
+
+1. compile libpq
+----------------
+
+set POSTGRES_HOME=C:\postgresql-7.0.2
+cd postgresql-7.0.2
+mkdir lib
+mkdir include
+cd src
+copy include\port\win32.h include\os.h
+edit interfaces\libpq\fe-connect.c and add as first statement in connectDBStart() the following code:
+ #ifdef WIN32
+ static int WeHaveCalledWSAStartup;
+ if (!WeHaveCalledWSAStartup) {
+ WSADATA wsaData;
+ if (WSAStartup(MAKEWORD(1, 1), &wsaData)) {
+ printfPQExpBuffer(&conn->errorMessage, "WSAStartup failed: errno=%d\n", h_errno);
+ goto connect_errReturn;
+ }
+ WeHaveCalledWSAStartup = 1;
+ }
+ #endif
+edit interfaces\libpq\win32.mak and change the flag /ML to /MD: CPP_PROJ=/nologo /MD ...
+nmake /f win32.mak
+cd ..
+copy src\interfaces\libpq\Release\libpq.lib lib
+copy src\interfaces\libpq\libpq-fe.h include
+copy src\include\postgres_ext.h include
+cd ..
+
+
+2. build DBD-Pg
+---------------
+
+cd DBD-Pg
+perl Makefile.PL CAPI=TRUE
+nmake
+set the environment variable PGHOST to the name of the postgresql server: set PGHOST=myserver
+add on the server a postgres user with the same name as the NT-User (eg Administrator)
+make sure, that your pg_hba.conf on the server is configured, such that a connection from another host will be accepted
+mkdir C:\tmp
+nmake test (expect to get errors concerning blobs)
+nmake install
--- /dev/null
+
+# $Id: dbd-pg.pod,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+=head1 NAME
+
+DBD::Pg - PostgreSQL database driver for the DBI module
+
+=head1 DESCRIPTION
+
+DBD::Pg is a Perl module which works with the DBI module to provide
+access to PostgreSQL databases.
+
+=head1 DBD::Pg
+
+=begin docbook
+<!-- The following blank =head1 is to allow us to use purely =head2 headings -->
+<!-- This keeps the POD fairly simple with regards to Pod::DocBook -->
+
+=end docbook
+
+=head1
+
+=head2 Version
+
+Version 0.91.
+
+=head2 Author and Contact Details
+
+The driver author is Edmund Mergl. He can be contacted via the
+I<dbi-users> mailing list.
+
+
+=head2 Supported Database Versions and Options
+
+The DBD-Pg-0.92 module supports Postgresql 6.5.
+
+
+=head2 Connect Syntax
+
+The C<DBI-E<gt>connect()> Data Source Name, or I<DSN>, can be one of the
+following:
+
+ dbi:Pg:dbname=$dbname
+ dbi:Pg:dbname=$dbname;host=$host;port=$port;options=$options;tty=$tty
+
+All parameters, including the userid and password parameter of the
+connect command, have a hard-coded default which can be overridden
+by setting appropriate environment variables:
+
+ Parameter Environment Variable Default
+ --------- -------------------- --------------
+ dbname PGDATABASE current userid
+ host PGHOST localhost
+ port PGPORT 5432
+ options PGOPTIONS ""
+ tty PGTTY ""
+ username PGUSER current userid
+ password PGPASSWORD ""
+
+There are no driver specific attributes for the C<DBI->connect()> method.
+
+
+=head2 Numeric Data Handling
+
+Postgresql supports the following numeric types:
+
+ Postgresql Range
+ ---------- --------------------------
+ int2 -32768 to +32767
+ int4 -2147483648 to +2147483647
+ float4 6 decimal places
+ float8 15 decimal places
+
+Some platforms also support the int8 type.
+C<DBD::Pg> always returns all numbers as strings.
+
+
+=head2 String Data Handling
+
+Postgresql supports the following string data types:
+
+ CHAR single character
+ CHAR(size) fixed length blank-padded
+ VARCHAR(size) variable length with limit
+ TEXT variable length
+
+All string data types have a limit of 4096 bytes.
+The CHAR type is fixed length and blank padded.
+
+There is no special handling for data with the 8th bit set. They
+are stored unchanged in the database.
+None of the character types can store embedded nulls and Unicode is
+not formally supported.
+
+Strings can be concatenated using the C<||> operator.
+
+
+=head2 Date Data Handling
+
+Postgresql supports the following date time data types:
+
+ Type Storage Recommendation Description
+ --------- -------- -------------------------- ----------------------------
+ abstime 4 bytes original date and time limited range
+ date 4 bytes SQL92 type wide range
+ datetime 8 bytes best general date and time wide range, high precision
+ interval 12 bytes SQL92 type equivalent to timespan
+ reltime 4 bytes original time interval limited range, low precision
+ time 4 bytes SQL92 type wide range
+ timespan 12 bytes best general time interval wide range, high precision
+ timestamp 4 bytes SQL92 type limited range
+
+ Data Type Range Resolution
+ ---------- ---------------------------------- -----------
+ abstime 1901-12-14 2038-01-19 1 sec
+ timestamp 1901-12-14 2038-01-19 1 sec
+ reltime -68 years +68 years 1 sec
+ tinterval -178000000 years +178000000 years 1 microsec
+ timespan -178000000 years 178000000 years 1 microsec
+ date 4713 BC 32767 AD 1 day
+ datetime 4713 BC 1465001 AD 1 microsec
+ time 00:00:00:00 23:59:59:99 1 microsec
+
+Postgresql supports a range of date formats:
+
+ Name Example
+ ----------- ----------------------
+ ISO 1997-12-17 0:37:16-08
+ SQL 12/17/1997 07:37:16.00 PST
+ Postgres Wed Dec 17 07:37:16 1997 PST
+ European 17/12/1997 15:37:16.00 MET
+ NonEuropean 12/17/1997 15:37:16.00 MET
+ US 12/17/1997 07:37:16.00 MET
+
+The default output format does not depend on the client/server locale.
+It depends on, in increasing priority: the PGDATESTYLE environment
+variable at the server, the PGDATESTYLE environment variable at the client, and
+the C<SET DATESTYLE> SQL command.
+
+All of the formats described above can be used for input. A great many
+others can also be used. There is no specific default input format.
+If the format of a date input is ambiguous then the current DATESTYLE
+is used to help disambiguate.
+
+If you specify a date/time value without a time component, the default
+time is 00:00:00 (midnight). To specify a date/time value without a date
+is not allowed.
+If a date with a two digit year is input then if the year was less than
+70, add 2000; otherwise, add 1900.
+
+The currect date/time is returned by the keyword C<'now'> or C<'current'>,
+which has to be casted to a valid data type. For example:
+
+ SELECT 'now'::datetime
+
+Postgresql supports a range of date time functions for converting
+between types, extracting parts of a date time value, truncating to a
+given unit, etc. The usual arithmetic can be performed on date and
+interval values, e.g., date-date=interval, etc.
+
+The following SQL expression can be used to convert an integer "seconds
+since 1-jan-1970 GMT" value to the corresponding database date time:
+
+ DATETIME(unixtime_field)
+
+and to do the reverse:
+
+ DATE_PART('epoch', datetime_field)
+
+The server stores all dates internally in GMT. Times are converted to
+local time on the database server before being sent to the client
+frontend, hence by default are in the server time zone.
+
+The TZ environment variable is used by the server as default time
+zone. The PGTZ environment variable on the client side is used to send
+the time zone information to the backend upon connection. The SQL C<SET
+TIME ZONE> command can set the time zone for the current session.
+
+
+=head2 LONG/BLOB Data Handling
+
+Postgresql handles BLOBS using a so called "large objects" type. The
+handling of this type differs from all other data types. The data are
+broken into chunks, which are stored in tuples in the database. Access
+to large objects is given by an interface which is modelled closely
+after the UNIX file system. The maximum size is limited by the file
+size of the operating system.
+
+
+If you just select the field, you get a "large object identifier" and
+not the data itself. The I<LongReadLen> and I<LongTruncOk> attributes are
+not implemented because they don't make sense in this case. The only
+method implemented by the driver is the undocumented DBI method
+C<blob_read()>.
+
+
+=head2 Other Data Handling issues
+
+The C<DBD::Pg> driver supports the C<type_info()> method.
+
+Postgresql supports automatic conversions between data types wherever
+it's reasonable.
+
+=head2 Transactions, Isolation and Locking
+
+Postgresql supports transactions.
+The current default isolation transaction level is "Serializable" and
+is currently implemented using table level locks. Both may change.
+No other isolation levels for transactions are supported.
+
+With AutoCommit on, a query never places a lock on a table. Readers
+never block writers and writers never block readers. This behavior
+changes whenever a transaction is started (AutoCommit off). Then a
+query induces a shared lock on a table and blocks anyone else
+until the transaction has been finished.
+
+The C<LOCK TABLE table_name> statement can be used to apply an explicit
+lock on a table. This only works inside a transaction (AutoCommit off).
+
+To ensure that a table being selected does not change before you make
+an update later in the transaction, you must explicitly lock it with a
+C<LOCK TABLE> statement before executing the select.
+
+
+=head2 No-Table Expression Select Syntax
+
+To select a constant expression, that is, an expression that doesn't involve
+data from a database table or view, just omit the "from" clause.
+Here's an example that selects the current time as a datetime:
+
+ SELECT 'now'::datetime;
+
+=head2 Table Join Syntax
+
+Outer joins are not supported. Inner joins use the traditional syntax.
+
+=head2 Table and Column Names
+
+The max size of table and column names cannot exceed 31 charaters in
+length.
+Only alphanumeric characters can be used; the first character must
+be a letter.
+
+If an identifier is enclosed by double quotation marks (C<">), it can
+contain any combination of characters except double quotation marks.
+
+Postgresql converts all identifiers to lower-case unless enclosed in
+double quotation marks.
+National character set characters can be used, if enclosed in quotation
+marks.
+
+
+=head2 Case Sensitivity of LIKE Operator
+
+Postgresql has the following string matching operators:
+
+ Glyph Description Example
+ ----- ---------------------------------------- -----------------------------
+ ~~ Same as SQL "LIKE" operator 'scrappy,marc' ~~ '%scrappy%'
+ !~~ Same as SQL "NOT LIKE" operator 'bruce' !~~ '%al%'
+ ~ Match (regex), case sensitive 'thomas' ~ '.*thomas.*'
+ ~* Match (regex), case insensitive 'thomas' ~* '.*Thomas.*'
+ !~ Does not match (regex), case sensitive 'thomas' !~ '.*Thomas.*'
+ !~* Does not match (regex), case insensitive 'thomas' !~ '.*vadim.*'
+
+
+=head2 Row ID
+
+The Postgresql "row id" pseudocolumn is called I<oid>, object identifier.
+It can be treated as a string and used to rapidly (re)select rows.
+
+
+=head2 Automatic Key or Sequence Generation
+
+Postgresql does not support automatic key generation such as "auto
+increment" or "system generated" keys.
+
+However, Postgresql does support "sequence generators". Any number of
+named sequence generators can be created in a database. Sequences
+are used via functions called C<NEXTVAL> and C<CURRVAL>. Typical usage:
+
+ INSERT INTO table (k, v) VALUES (nextval('seq_name'), ?);
+
+To get the value just inserted, you can use the corresponding C<currval()>
+SQL function in the same session, or
+
+ SELECT last_value FROM seq_name
+
+
+=head2 Automatic Row Numbering and Row Count Limiting
+
+Postgresql does not support any way of automatically numbering returned rows.
+
+
+=head2 Parameter Binding
+
+Parameter binding is emulated by the driver.
+Both the C<?> and C<:1> style of placeholders are supported.
+
+The TYPE attribute of the C<bind_param()> method may be used to
+influence how parameters are treated. These SQL types are bound as
+VARCHAR: SQL_NUMERIC, SQL_DECIMAL, SQL_INTEGER, SQL_SMALLINT,
+SQL_FLOAT, SQL_REAL, SQL_DOUBLE, SQL_VARCHAR.
+
+The SQL_CHAR type is bound as a CHAR thus enabling fixed-width blank
+padded comparison semantics.
+
+Unsupported values of the TYPE attribute generate a warning.
+
+
+=head2 Stored Procedures
+
+C<DBD::Pg> does not support stored procedures.
+
+
+=head2 Table Metadata
+
+C<DBD::Pg> supports the C<table_info()> method.
+
+The I<pg_attribute> table contains detailed information about all columns
+of all the tables in the database, one row per table.
+
+The I<pg_index> table contains detailed information about all indexes in
+the database, one row per index.
+
+Primary keys are implemented as unique indexes. See I<pg_index> above.
+
+
+=head2 Driver-specific Attributes and Methods
+
+There are no significant C<DBD::Pg> driver-specific database handle attributes.
+
+C<DBD::Pg> has the following driver-specific statement handle attributes:
+
+=over 8
+
+=item I<pg_size>
+
+Returns a reference to an array of integer values for each column. The
+integer shows the storage (not display) size of the column in bytes.
+Variable length columns are indicated by -1.
+
+=item I<pg_type>
+
+Returns a reference to an array of strings for each column. The string
+shows the name of the data type.
+
+=item I<pg_oid_status>
+
+Returns the OID of the last INSERT command.
+
+=item I<pg_cmd_status>
+
+Returns the name of the last command type. Possible types are: INSERT,
+DELETE, UPDATE, SELECT.
+
+=back
+
+
+C<DBD::Pg> has no private methods.
+
+
+=head2 Positioned updates and deletes
+
+Postgresql does not support positioned updates or deletes.
+
+
+=head2 Differences from the DBI Specification
+
+C<DBD::Pg> has no significant differences in behavior from the
+current DBI specification.
+
+Note that C<DBD::Pg> does not fully parse the statement until
+it's executed. Thus attributes like I<$sth-E<gt>{NUM_OF_FIELDS}> are not
+available until after C<$sth-E<gt>execute> has been called. This is valid
+behaviour but is important to note when porting applications
+originally written for other drivers.
+
+
+=head2 URLs to More Database/Driver Specific Information
+
+ http://www.postgresql.org
+
+
+=head2 Concurrent use of Multiple Handles
+
+C<DBD::Pg> supports an unlimited number of concurrent database
+connections to one or more databases.
+
+It also supports the preparation and execution of a new statement
+handle while still fetching data from another statement handle,
+provided it is
+associated with the same database handle.
+
+
+=head2 Other Significant Database or Driver Features
+
+Postgres offers substantial additional power by incorporating the
+following four additional basic concepts in such a way that users can
+easily extend the system: classes, inheritance, types, and functions.
+
+Other features provide additional power and flexibility: constraints,
+triggers, rules, transaction integrity, procedural languages, and large objects.
+
+It's also free Open Source Software with an active community of developers.
+
+=cut
+
+# This driver summary for DBD::Pg is Copyright (c) 1999 Tim Bunce
+# and Edmund Mergl.
+# $Id: dbd-pg.pod,v 1.1 2004-04-29 09:21:28 ivan Exp $
--- /dev/null
+/*
+ $Id: dbdimp.c,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+ Copyright (c) 1997,1998,1999,2000 Edmund Mergl
+ Copyright (c) 2002 Jeffrey W. Baker
+ Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the Perl README file.
+
+*/
+
+
+/*
+ hard-coded OIDs: (here we need the postgresql types)
+ pg_sql_type() 1042 (bpchar), 1043 (varchar)
+ ddb_st_fetch() 1042 (bpchar), 16 (bool)
+ ddb_preparse() 1043 (varchar)
+ pgtype_bind_ok()
+*/
+
+#include "Pg.h"
+
+/* XXX DBI should provide a better version of this */
+#define IS_DBI_HANDLE(h) (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P')
+
+DBISTATE_DECLARE;
+
+/* hard-coded array delimiter */
+static char* array_delimiter = ",";
+
+static void dbd_preparse (imp_sth_t *imp_sth, char *statement);
+
+
+void
+dbd_init (dbistate)
+ dbistate_t *dbistate;
+{
+ DBIS = dbistate;
+}
+
+
+int
+dbd_discon_all (drh, imp_drh)
+ SV *drh;
+ imp_drh_t *imp_drh;
+{
+ dTHR;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_discon_all\n"); }
+
+ /* The disconnect_all concept is flawed and needs more work */
+ if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) {
+ sv_setiv(DBIc_ERR(imp_drh), (IV)1);
+ sv_setpv(DBIc_ERRSTR(imp_drh),
+ (char*)"disconnect_all not implemented");
+ DBIh_EVENT2(drh, ERROR_event,
+ DBIc_ERR(imp_drh), DBIc_ERRSTR(imp_drh));
+ return FALSE;
+ }
+ if (perl_destruct_level) {
+ perl_destruct_level = 0;
+ }
+ return FALSE;
+}
+
+
+/* Database specific error handling. */
+
+void
+pg_error (h, error_num, error_msg)
+ SV *h;
+ int error_num;
+ char *error_msg;
+{
+ D_imp_xxh(h);
+ char *err, *src, *dst;
+ int len = strlen(error_msg);
+
+ err = (char *)malloc(len + 1);
+ if (!err) {
+ return;
+ }
+ src = error_msg;
+ dst = err;
+
+ /* copy error message without trailing newlines */
+ while (*src != '\0' && *src != '\n') {
+ *dst++ = *src++;
+ }
+ *dst = '\0';
+
+ sv_setiv(DBIc_ERR(imp_xxh), (IV)error_num); /* set err early */
+ sv_setpv(DBIc_ERRSTR(imp_xxh), (char*)err);
+ DBIh_EVENT2(h, ERROR_event, DBIc_ERR(imp_xxh), DBIc_ERRSTR(imp_xxh));
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "%s error %d recorded: %s\n", err, error_num, SvPV(DBIc_ERRSTR(imp_xxh),na)); }
+ free(err);
+}
+
+static int
+pgtype_bind_ok (dbtype)
+ int dbtype;
+{
+ /* basically we support types that can be returned as strings */
+ switch(dbtype) {
+ case 16: /* bool */
+ case 17: /* bytea */
+ case 18: /* char */
+ case 20: /* int8 */
+ case 21: /* int2 */
+ case 23: /* int4 */
+ case 25: /* text */
+ case 26: /* oid */
+ case 700: /* float4 */
+ case 701: /* float8 */
+ case 702: /* abstime */
+ case 703: /* reltime */
+ case 704: /* tinterval */
+ case 1042: /* bpchar */
+ case 1043: /* varchar */
+ case 1082: /* date */
+ case 1083: /* time */
+ case 1184: /* datetime */
+ case 1186: /* timespan */
+ case 1296: /* timestamp */
+ return 1;
+ }
+ return 0;
+}
+
+
+/* ================================================================== */
+
+int
+pg_db_login (dbh, imp_dbh, dbname, uid, pwd)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ char *dbname;
+ char *uid;
+ char *pwd;
+{
+ dTHR;
+
+ char *conn_str;
+ char *src;
+ char *dest;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "pg_db_login\n"); }
+
+ /* build connect string */
+ /* DBD-Pg syntax: 'dbname=dbname;host=host;port=port' */
+ /* pgsql syntax: 'dbname=dbname host=host port=port user=uid password=pwd' */
+
+ conn_str = (char *)malloc(strlen(dbname) + strlen(uid) + strlen(pwd) + 16 + 1);
+ if (! conn_str) {
+ return 0;
+ }
+
+ src = dbname;
+ dest = conn_str;
+ while (*src) {
+ if (*src != ';') {
+ *dest++ = *src++;
+ continue;
+ }
+ *dest++ = ' ';
+ src++;
+ }
+ *dest = '\0';
+
+ if (strlen(uid)) {
+ strcat(conn_str, " user=");
+ strcat(conn_str, uid);
+ }
+ if (strlen(uid) && strlen(pwd)) {
+ strcat(conn_str, " password=");
+ strcat(conn_str, pwd);
+ }
+
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "pg_db_login: conn_str = >%s<\n", conn_str); }
+
+ /* make a connection to the database */
+ imp_dbh->conn = PQconnectdb(conn_str);
+ free(conn_str);
+
+ /* check to see that the backend connection was successfully made */
+ if (PQstatus(imp_dbh->conn) != CONNECTION_OK) {
+ pg_error(dbh, PQstatus(imp_dbh->conn), PQerrorMessage(imp_dbh->conn));
+ PQfinish(imp_dbh->conn);
+ return 0;
+ }
+
+ imp_dbh->init_commit = 1; /* initialize AutoCommit */
+ imp_dbh->pg_auto_escape = 1; /* initialize pg_auto_escape */
+ imp_dbh->pg_bool_tf = 0; /* initialize pg_bool_tf */
+
+ DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */
+ DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */
+ return 1;
+}
+
+
+int
+dbd_db_getfd (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ char id;
+ SV* retsv;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_getfd\n"); }
+
+ return PQsocket(imp_dbh->conn);
+}
+
+SV *
+dbd_db_pg_notifies (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ char id;
+ PGnotify* notify;
+ AV* ret;
+ SV* retsv;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_pg_notifies\n"); }
+
+ PQconsumeInput(imp_dbh->conn);
+
+ notify = PQnotifies(imp_dbh->conn);
+
+ if (!notify) return &sv_undef;
+
+ ret=newAV();
+
+ av_push(ret, newSVpv(notify->relname,0) );
+ av_push(ret, newSViv(notify->be_pid) );
+
+ /* Should free notify memory with PQfreemem() */
+
+ retsv = newRV(sv_2mortal((SV*)ret));
+
+ return retsv;
+}
+
+int
+dbd_db_ping (dbh)
+ SV *dbh;
+{
+ char id;
+ D_imp_dbh(dbh);
+ PGresult* result;
+ ExecStatusType status;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_ping\n"); }
+
+ if (NULL != imp_dbh->conn) {
+ result = PQexec(imp_dbh->conn, " ");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+
+ if (PGRES_EMPTY_QUERY != status) {
+ return 0;
+ }
+
+ return 1;
+ }
+
+ return 0;
+}
+
+
+int
+dbd_db_commit (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_commit\n"); }
+
+ /* no commit if AutoCommit = on */
+ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) {
+ return 0;
+ }
+
+ if (NULL != imp_dbh->conn) {
+ PGresult* result = 0;
+ ExecStatusType commitstatus, beginstatus;
+
+ /* execute commit */
+ result = PQexec(imp_dbh->conn, "commit");
+ commitstatus = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+
+ /* check result */
+ if (commitstatus != PGRES_COMMAND_OK) {
+ /* Only put the error message in DBH->errstr */
+ pg_error(dbh, commitstatus, PQerrorMessage(imp_dbh->conn));
+ }
+
+ /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */
+ result = PQexec(imp_dbh->conn, "begin");
+ beginstatus = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (beginstatus != PGRES_COMMAND_OK) {
+ /* Maybe add some loud barf here? Raising some very high error? */
+ pg_error(dbh, beginstatus, "begin failed\n");
+ return 0;
+ }
+
+ /* if the initial COMMIT failed, return 0 now */
+ if (commitstatus != PGRES_COMMAND_OK) {
+ return 0;
+ }
+
+ return 1;
+ }
+
+ return 0;
+}
+
+
+int
+dbd_db_rollback (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_rollback\n"); }
+
+ /* no rollback if AutoCommit = on */
+ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) {
+ return 0;
+ }
+
+ if (NULL != imp_dbh->conn) {
+ PGresult* result = 0;
+ ExecStatusType status;
+
+ /* execute rollback */
+ result = PQexec(imp_dbh->conn, "rollback");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+
+ /* check result */
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(dbh, status, "rollback failed\n");
+ return 0;
+ }
+
+ /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */
+ result = PQexec(imp_dbh->conn, "begin");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(dbh, status, "begin failed\n");
+ return 0;
+ }
+
+ return 1;
+ }
+
+ return 0;
+}
+
+
+int
+dbd_db_disconnect (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ dTHR;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect\n"); }
+
+ /* We assume that disconnect will always work */
+ /* since most errors imply already disconnected. */
+ DBIc_ACTIVE_off(imp_dbh);
+
+ if (NULL != imp_dbh->conn) {
+ /* rollback if AutoCommit = off */
+ if (DBIc_has(imp_dbh, DBIcf_AutoCommit) == FALSE) {
+ PGresult* result = 0;
+ ExecStatusType status;
+ result = PQexec(imp_dbh->conn, "rollback");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(dbh, status, "rollback failed\n");
+ return 0;
+ }
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect: AutoCommit=off -> rollback\n"); }
+ }
+
+ PQfinish(imp_dbh->conn);
+
+ imp_dbh->conn = NULL;
+ }
+
+ /* We don't free imp_dbh since a reference still exists */
+ /* The DESTROY method is the only one to 'free' memory. */
+ /* Note that statement objects may still exists for this dbh! */
+ return 1;
+}
+
+
+void
+dbd_db_destroy (dbh, imp_dbh)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_destroy\n"); }
+
+ if (DBIc_ACTIVE(imp_dbh)) {
+ dbd_db_disconnect(dbh, imp_dbh);
+ }
+
+ /* Nothing in imp_dbh to be freed */
+ DBIc_IMPSET_off(imp_dbh);
+}
+
+
+int
+dbd_db_STORE_attrib (dbh, imp_dbh, keysv, valuesv)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ SV *keysv;
+ SV *valuesv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ int newval = SvTRUE(valuesv);
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_STORE\n"); }
+
+ if (kl==10 && strEQ(key, "AutoCommit")) {
+ int oldval = DBIc_has(imp_dbh, DBIcf_AutoCommit);
+ DBIc_set(imp_dbh, DBIcf_AutoCommit, newval);
+ if (oldval == FALSE && newval != FALSE && imp_dbh->init_commit) {
+ /* do nothing, fall through */
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: initialize AutoCommit to on\n"); }
+ } else if (oldval == FALSE && newval != FALSE) {
+ if (NULL != imp_dbh->conn) {
+ /* commit any outstanding changes */
+ PGresult* result = 0;
+ ExecStatusType status;
+ result = PQexec(imp_dbh->conn, "commit");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(dbh, status, "commit failed\n");
+ return 0;
+ }
+ }
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to on: commit\n"); }
+ } else if ((oldval != FALSE && newval == FALSE) || (oldval == FALSE && newval == FALSE && imp_dbh->init_commit)) {
+ if (NULL != imp_dbh->conn) {
+ /* start new transaction */
+ PGresult* result = 0;
+ ExecStatusType status;
+ result = PQexec(imp_dbh->conn, "begin");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(dbh, status, "begin failed\n");
+ return 0;
+ }
+ }
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to off: begin\n"); }
+ }
+ /* only needed once */
+ imp_dbh->init_commit = 0;
+ return 1;
+ } else if (kl==14 && strEQ(key, "pg_auto_escape")) {
+ imp_dbh->pg_auto_escape = newval;
+ } else if (kl==10 && strEQ(key, "pg_bool_tf")) {
+ imp_dbh->pg_bool_tf = newval;
+#ifdef SvUTF8_off
+ } else if (kl==14 && strEQ(key, "pg_enable_utf8")) {
+ imp_dbh->pg_enable_utf8 = newval;
+#endif
+ } else {
+ return 0;
+ }
+}
+
+
+SV *
+dbd_db_FETCH_attrib (dbh, imp_dbh, keysv)
+ SV *dbh;
+ imp_dbh_t *imp_dbh;
+ SV *keysv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ SV *retsv = Nullsv;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_FETCH\n"); }
+
+ if (kl==10 && strEQ(key, "AutoCommit")) {
+ retsv = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit));
+ } else if (kl==14 && strEQ(key, "pg_auto_escape")) {
+ retsv = newSViv((IV)imp_dbh->pg_auto_escape);
+ } else if (kl==10 && strEQ(key, "pg_bool_tf")) {
+ retsv = newSViv((IV)imp_dbh->pg_bool_tf);
+#ifdef SvUTF8_off
+ } else if (kl==14 && strEQ(key, "pg_enable_utf8")) {
+ retsv = newSViv((IV)imp_dbh->pg_enable_utf8);
+#endif
+ } else if (kl==11 && strEQ(key, "pg_INV_READ")) {
+ retsv = newSViv((IV)INV_READ);
+ } else if (kl==12 && strEQ(key, "pg_INV_WRITE")) {
+ retsv = newSViv((IV)INV_WRITE);
+ }
+
+ if (!retsv) {
+ return Nullsv;
+ }
+ if (retsv == &sv_yes || retsv == &sv_no) {
+ return retsv; /* no need to mortalize yes or no */
+ }
+ return sv_2mortal(retsv);
+}
+
+
+/* driver specific functins */
+
+
+int
+pg_db_lo_open (dbh, lobjId, mode)
+ SV *dbh;
+ unsigned int lobjId;
+ int mode;
+{
+ D_imp_dbh(dbh);
+ return lo_open(imp_dbh->conn, lobjId, mode);
+}
+
+
+int
+pg_db_lo_close (dbh, fd)
+ SV *dbh;
+ int fd;
+{
+ D_imp_dbh(dbh);
+ return lo_close(imp_dbh->conn, fd);
+}
+
+
+int
+pg_db_lo_read (dbh, fd, buf, len)
+ SV *dbh;
+ int fd;
+ char *buf;
+ int len;
+{
+ D_imp_dbh(dbh);
+ return lo_read(imp_dbh->conn, fd, buf, len);
+}
+
+
+int
+pg_db_lo_write (dbh, fd, buf, len)
+ SV *dbh;
+ int fd;
+ char *buf;
+ int len;
+{
+ D_imp_dbh(dbh);
+ return lo_write(imp_dbh->conn, fd, buf, len);
+}
+
+
+int
+pg_db_lo_lseek (dbh, fd, offset, whence)
+ SV *dbh;
+ int fd;
+ int offset;
+ int whence;
+{
+ D_imp_dbh(dbh);
+ return lo_lseek(imp_dbh->conn, fd, offset, whence);
+}
+
+
+unsigned int
+pg_db_lo_creat (dbh, mode)
+ SV *dbh;
+ int mode;
+{
+ D_imp_dbh(dbh);
+ return lo_creat(imp_dbh->conn, mode);
+}
+
+
+int
+pg_db_lo_tell (dbh, fd)
+ SV *dbh;
+ int fd;
+{
+ D_imp_dbh(dbh);
+ return lo_tell(imp_dbh->conn, fd);
+}
+
+
+int
+pg_db_lo_unlink (dbh, lobjId)
+ SV *dbh;
+ unsigned int lobjId;
+{
+ D_imp_dbh(dbh);
+ return lo_unlink(imp_dbh->conn, lobjId);
+}
+
+
+unsigned int
+pg_db_lo_import (dbh, filename)
+ SV *dbh;
+ char *filename;
+{
+ D_imp_dbh(dbh);
+ return lo_import(imp_dbh->conn, filename);
+}
+
+
+int
+pg_db_lo_export (dbh, lobjId, filename)
+ SV *dbh;
+ unsigned int lobjId;
+ char *filename;
+{
+ D_imp_dbh(dbh);
+ return lo_export(imp_dbh->conn, lobjId, filename);
+}
+
+
+int
+pg_db_putline (dbh, buffer)
+ SV *dbh;
+ char *buffer;
+{
+ D_imp_dbh(dbh);
+ return PQputline(imp_dbh->conn, buffer);
+}
+
+
+int
+pg_db_getline (dbh, buffer, length)
+ SV *dbh;
+ char *buffer;
+ int length;
+{
+ D_imp_dbh(dbh);
+ return PQgetline(imp_dbh->conn, buffer, length);
+}
+
+
+int
+pg_db_endcopy (dbh)
+ SV *dbh;
+{
+ D_imp_dbh(dbh);
+ return PQendcopy(imp_dbh->conn);
+}
+
+
+/* ================================================================== */
+
+
+int
+dbd_st_prepare (sth, imp_sth, statement, attribs)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ char *statement;
+ SV *attribs;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_prepare: statement = >%s<\n", statement); }
+
+ /* scan statement for '?', ':1' and/or ':foo' style placeholders */
+ dbd_preparse(imp_sth, statement);
+
+ /* initialize new statement handle */
+ imp_sth->result = 0;
+ imp_sth->cur_tuple = 0;
+
+ DBIc_IMPSET_on(imp_sth);
+ return 1;
+}
+
+
+static void
+dbd_preparse (imp_sth, statement)
+ imp_sth_t *imp_sth;
+ char *statement;
+{
+ bool in_literal = FALSE;
+ char in_comment = '\0';
+ char *src, *start, *dest;
+ phs_t phs_tpl;
+ SV *phs_sv;
+ int idx=0;
+ char *style="", *laststyle=Nullch;
+ STRLEN namelen;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_preparse: statement = >%s<\n", statement); }
+
+ /* allocate room for copy of statement with spare capacity */
+ /* for editing '?' or ':1' into ':p1'. */
+ /* */
+ /* Note: the calculated length used here for the safemalloc */
+ /* isn't related in any way to the actual worst case length */
+ /* of the translated statement, but allowing for 3 times */
+ /* the length of the original statement should be safe... */
+ imp_sth->statement = (char*)safemalloc(strlen(statement) * 3 + 1);
+
+ /* initialise phs ready to be cloned per placeholder */
+ memset(&phs_tpl, 0, sizeof(phs_tpl));
+ phs_tpl.ftype = 1043; /* VARCHAR */
+
+ src = statement;
+ dest = imp_sth->statement;
+ while(*src) {
+
+ if (in_comment) {
+ /* SQL-style and C++-style */
+ if ((in_comment == '-' || in_comment == '/') && *src == '\n') {
+ in_comment = '\0';
+ }
+ /* C-style */
+ else if (in_comment == '*' && *src == '*' && *(src+1) == '/') {
+ *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
+ in_comment = '\0';
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ if (in_literal) {
+ /* check if literal ends but keep quotes in literal */
+ if (*src == in_literal) {
+ int bs=0;
+ char *str;
+ str = src-1;
+ while (*(str-bs) == '\\')
+ bs++;
+ if (!(bs & 1))
+ in_literal = 0;
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* Look for comments: SQL-style or C++-style or C-style */
+ if ((*src == '-' && *(src+1) == '-') ||
+ (*src == '/' && *(src+1) == '/') ||
+ (*src == '/' && *(src+1) == '*'))
+ {
+ in_comment = *(src+1);
+ /* We know *src & the next char are to be copied, so do */
+ /* it. In the case of C-style comments, it happens to */
+ /* help us avoid slash-asterisk-slash oddities. */
+ *dest++ = *src++;
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* check if no placeholders */
+ if (*src != ':' && *src != '?') {
+ if (*src == '\'' || *src == '"') {
+ in_literal = *src;
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* check for cast operator */
+ if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) {
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* only here for : or ? outside of a comment or literal and no cast */
+
+ start = dest; /* save name inc colon */
+ *dest++ = *src++;
+ if (*start == '?') { /* X/Open standard */
+ sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */
+ dest = start+strlen(start);
+ style = "?";
+
+ } else if (isDIGIT(*src)) { /* ':1' */
+ idx = atoi(src);
+ *dest++ = 'p'; /* ':1'->':p1' */
+ if (idx <= 0) {
+ croak("Placeholder :%d invalid, placeholders must be >= 1", idx);
+ }
+ while(isDIGIT(*src)) {
+ *dest++ = *src++;
+ }
+ style = ":1";
+
+ } else if (isALNUM(*src)) { /* ':foo' */
+ while(isALNUM(*src)) { /* includes '_' */
+ *dest++ = *src++;
+ }
+ style = ":foo";
+ } else { /* perhaps ':=' PL/SQL construct */
+ continue;
+ }
+ *dest = '\0'; /* handy for debugging */
+ namelen = (dest-start);
+ if (laststyle && style != laststyle) {
+ croak("Can't mix placeholder styles (%s/%s)",style,laststyle);
+ }
+ laststyle = style;
+ if (imp_sth->all_params_hv == NULL) {
+ imp_sth->all_params_hv = newHV();
+ }
+ phs_tpl.sv = &sv_undef;
+ phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1);
+ hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0);
+ strcpy( ((phs_t*)(void*)SvPVX(phs_sv))->name, start);
+ }
+ *dest = '\0';
+ if (imp_sth->all_params_hv) {
+ DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv);
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n", (int)DBIc_NUM_PARAMS(imp_sth)); }
+ }
+}
+
+
+/* if it LOOKS like a string, this function will determine whether the type needs to be surrounded in single quotes */
+static int pg_sql_needquote (sql_type)
+ int sql_type;
+{
+ if (sql_type > 1000 || sql_type == 17 || sql_type == 25 ) {
+ return 1;
+ }
+ return 0;
+}
+
+
+
+static int
+pg_sql_type (imp_sth, name, sql_type)
+ imp_sth_t *imp_sth;
+ char *name;
+ int sql_type;
+{
+ switch (sql_type) {
+ case SQL_CHAR:
+ return 1042; /* bpchar */
+ case SQL_NUMERIC:
+ return 700; /* float4 */
+ case SQL_DECIMAL:
+ return 700; /* float4 */
+ case SQL_INTEGER:
+ return 23; /* int4 */
+ case SQL_SMALLINT:
+ return 21; /* int2 */
+ case SQL_FLOAT:
+ return 700; /* float4 */
+ case SQL_REAL:
+ return 701; /* float8 */
+ case SQL_DOUBLE:
+ return 20; /* int8 */
+ case SQL_VARCHAR:
+ return 1043; /* varchar */
+ case SQL_BINARY:
+ return 17; /* bytea */
+ default:
+ if (DBIc_WARN(imp_sth) && imp_sth && name) {
+ warn("SQL type %d for '%s' is not fully supported, bound as VARCHAR instead",
+ sql_type, name);
+ }
+ return pg_sql_type(imp_sth, name, SQL_VARCHAR);
+ }
+}
+
+static int
+sql_pg_type (imp_sth, name, sql_type)
+ imp_sth_t *imp_sth;
+ char *name;
+ int sql_type;
+{
+ if (dbis->debug >= 1) {
+ PerlIO_printf(DBILOGFP, "sql_pg_type name '%s' type '%d'\n", name, sql_type );
+ }
+
+ switch (sql_type) {
+ case 17: /* bytea */
+ return SQL_BINARY;
+ case 20: /* int8 */
+ return SQL_DOUBLE;
+ case 21: /* int2 */
+ return SQL_SMALLINT;
+ case 23: /* int4 */
+ return SQL_INTEGER;
+ case 700: /* float4 */
+ return SQL_NUMERIC;
+ case 701: /* float8 */
+ return SQL_REAL;
+ case 1042: /* bpchar */
+ return SQL_CHAR;
+ case 1043: /* varchar */
+ return SQL_VARCHAR;
+ case 1082: /* date */
+ return SQL_DATE;
+ case 1083: /* time */
+ return SQL_TIME;
+ case 1296: /* date */
+ return SQL_TIMESTAMP;
+
+ default:
+ return sql_type;
+ }
+}
+
+
+static int
+dbd_rebind_ph (sth, imp_sth, phs)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ phs_t *phs;
+{
+ STRLEN value_len;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rebind\n"); }
+
+ /* convert to a string ASAP */
+ if (!SvPOK(phs->sv) && SvOK(phs->sv)) {
+ sv_2pv(phs->sv, &na);
+ }
+
+ if (dbis->debug >= 2) {
+ char *val = neatsvpv(phs->sv,0);
+ PerlIO_printf(DBILOGFP, " bind %s <== %.1000s (", phs->name, val);
+ if (SvOK(phs->sv)) {
+ PerlIO_printf(DBILOGFP, "size %ld/%ld/%ld, ", (long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen);
+ } else {
+ PerlIO_printf(DBILOGFP, "NULL, ");
+ }
+ PerlIO_printf(DBILOGFP, "ptype %d, otype %d%s)\n", (int)SvTYPE(phs->sv), phs->ftype, (phs->is_inout) ? ", inout" : "");
+ }
+
+ /* At the moment we always do sv_setsv() and rebind. */
+ /* Later we may optimise this so that more often we can */
+ /* just copy the value & length over and not rebind. */
+
+ if (phs->is_inout) { /* XXX */
+ if (SvREADONLY(phs->sv)) {
+ croak(no_modify);
+ }
+ /* phs->sv _is_ the real live variable, it may 'mutate' later */
+ /* pre-upgrade high to reduce risk of SvPVX realloc/move */
+ (void)SvUPGRADE(phs->sv, SVt_PVNV);
+ /* ensure room for result, 28 is magic number (see sv_2pv) */
+ SvGROW(phs->sv, (phs->maxlen < 28) ? 28 : phs->maxlen+1);
+ }
+ else {
+ /* phs->sv is copy of real variable, upgrade to at least string */
+ (void)SvUPGRADE(phs->sv, SVt_PV);
+ }
+
+ /* At this point phs->sv must be at least a PV with a valid buffer, */
+ /* even if it's undef (null) */
+ /* Here we set phs->progv, phs->indp, and value_len. */
+ if (SvOK(phs->sv)) {
+ phs->progv = SvPV(phs->sv, value_len);
+ phs->indp = 0;
+ }
+ else { /* it's null but point to buffer in case it's an out var */
+ phs->progv = SvPVX(phs->sv);
+ phs->indp = -1;
+ value_len = 0;
+ }
+ phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */
+ phs->maxlen = SvLEN(phs->sv)-1; /* avail buffer space */
+ if (phs->maxlen < 0) { /* can happen with nulls */
+ phs->maxlen = 0;
+ }
+
+ phs->alen = value_len + phs->alen_incnull;
+
+ imp_sth->all_params_len += SvOK(phs->sv) ? phs->alen : 4; /* NULL */
+
+ if (dbis->debug >= 3) {
+ PerlIO_printf(DBILOGFP, " bind %s <== '%.*s' (size %ld/%ld, otype %d, indp %d)\n",
+ phs->name,
+ (int)(phs->alen>SvIV(DBIS->neatsvpvlen) ? SvIV(DBIS->neatsvpvlen) : phs->alen),
+ (phs->progv) ? phs->progv : "",
+ (long)phs->alen, (long)phs->maxlen, phs->ftype, phs->indp);
+ }
+
+ return 1;
+}
+
+
+void dereference(value)
+SV** value;
+{
+ AV* buf;
+ SV* val;
+ char *src;
+ int is_ref;
+ STRLEN len;
+
+ if (SvTYPE(SvRV(*value)) != SVt_PVAV)
+ croak("Not an array reference (%s)", neatsvpv(*value,0));
+
+ buf = (AV *) SvRV(*value);
+ sv_setpv(*value, "{");
+ while ( SvOK(val = av_shift(buf)) ) {
+ is_ref = SvROK(val);
+ if (is_ref)
+ dereference(&val);
+ else
+ sv_catpv(*value, "\"");
+ /* Quote */
+ src = SvPV(val, len);
+ while (len--) {
+ if (!is_ref && *src == '\"')
+ sv_catpv(*value, "\\");
+ sv_catpvn(*value, src++, 1);
+ }
+ /* End of quote */
+ if (!is_ref)
+ sv_catpv(*value, "\"");
+ if (av_len(buf) > -1)
+ sv_catpv(*value, array_delimiter);
+ }
+ sv_catpv(*value, "}");
+ av_clear(buf);
+}
+
+int
+dbd_bind_ph (sth, imp_sth, ph_namesv, newvalue, sql_type, attribs, is_inout, maxlen)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *ph_namesv;
+ SV *newvalue;
+ IV sql_type;
+ SV *attribs;
+ int is_inout;
+ IV maxlen;
+{
+ SV **phs_svp;
+ STRLEN name_len;
+ char *name;
+ char namebuf[30];
+ phs_t *phs;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_bind_ph\n"); }
+
+ /* check if placeholder was passed as a number */
+
+ if (SvGMAGICAL(ph_namesv)) { /* eg if from tainted expression */
+ mg_get(ph_namesv);
+ }
+ if (!SvNIOKp(ph_namesv)) {
+ name = SvPV(ph_namesv, name_len);
+ }
+ if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) {
+ sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv));
+ name = namebuf;
+ name_len = strlen(name);
+ }
+ assert(name != Nullch);
+
+ if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic */
+ croak("Can't bind a non-scalar value (%s)", neatsvpv(newvalue,0));
+ }
+ if (SvROK(newvalue) && !IS_DBI_HANDLE(newvalue)) {
+ /* dbi handle allowed for cursor variables */
+ dereference(&newvalue);
+ }
+ if (SvTYPE(newvalue) == SVt_PVLV && is_inout) { /* may allow later */
+ croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)");
+ }
+
+ if (dbis->debug >= 2) {
+ PerlIO_printf(DBILOGFP, " bind %s <== %s (type %ld", name, neatsvpv(newvalue,0), (long)sql_type);
+ if (is_inout) {
+ PerlIO_printf(DBILOGFP, ", inout 0x%lx, maxlen %ld", (long)newvalue, (long)maxlen);
+ }
+ if (attribs) {
+ PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0));
+ }
+ PerlIO_printf(DBILOGFP, ")\n");
+ }
+
+ phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0);
+ if (phs_svp == NULL) {
+ croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0));
+ }
+ phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
+
+ if (phs->sv == &sv_undef) { /* first bind for this placeholder */
+ phs->ftype = 1043; /* our default type VARCHAR */
+ phs->is_inout = is_inout;
+ if (is_inout) {
+ /* phs->sv assigned in the code below */
+ ++imp_sth->has_inout_params;
+ /* build array of phs's so we can deal with out vars fast */
+ if (!imp_sth->out_params_av) {
+ imp_sth->out_params_av = newAV();
+ }
+ av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp));
+ }
+
+ if (attribs) { /* only look for pg_type on first bind of var */
+ SV **svp;
+ /* Setup / Clear attributes as defined by attribs. */
+ /* XXX If attribs is EMPTY then reset attribs to default? */
+ if ( (svp = hv_fetch((HV*)SvRV(attribs), "pg_type", 7, 0)) != NULL) {
+ int pg_type = SvIV(*svp);
+ if (!pgtype_bind_ok(pg_type)) {
+ croak("Can't bind %s, pg_type %d not supported by DBD::Pg", phs->name, pg_type);
+ }
+ if (sql_type) {
+ croak("Can't specify both TYPE (%d) and pg_type (%d) for %s", sql_type, pg_type, phs->name);
+ }
+ phs->ftype = pg_type;
+ }
+ }
+ if (sql_type) {
+ /* SQL_BINARY (-2) is deprecated. */
+ if (sql_type == -2 && DBIc_WARN(imp_sth)) {
+ warn("Use of SQL type SQL_BINARY (%d) is deprecated. Use { pg_type => DBD::Pg::PG_BYTEA } instead.", sql_type);
+ }
+ phs->ftype = pg_sql_type(imp_sth, phs->name, sql_type);
+ }
+ } /* was first bind for this placeholder */
+
+ /* check later rebinds for any changes */
+ else if (is_inout || phs->is_inout) {
+ croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)", phs->name, phs->is_inout , is_inout);
+ }
+ else if (sql_type && phs->ftype != pg_sql_type(imp_sth, phs->name, sql_type)) {
+ croak("Can't change TYPE of param %s to %d after initial bind", phs->name, sql_type);
+ }
+
+ phs->maxlen = maxlen; /* 0 if not inout */
+
+ if (!is_inout) { /* normal bind to take a (new) copy of current value */
+ if (phs->sv == &sv_undef) { /* (first time bind) */
+ phs->sv = newSV(0);
+ }
+ sv_setsv(phs->sv, newvalue);
+ } else if (newvalue != phs->sv) {
+ if (phs->sv) {
+ SvREFCNT_dec(phs->sv);
+ }
+ phs->sv = SvREFCNT_inc(newvalue); /* point to live var */
+ }
+
+ return dbd_rebind_ph(sth, imp_sth, phs);
+}
+
+
+int
+dbd_st_execute (sth, imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ dTHR;
+
+ D_imp_dbh_from_sth;
+ ExecStatusType status = -1;
+ char *cmdStatus;
+ char *cmdTuples;
+ char *statement;
+ int ret = -2;
+ int num_fields;
+ int i;
+ STRLEN len;
+ bool in_literal = FALSE;
+ char in_comment = '\0';
+ char *src;
+ char *dest;
+ char *val;
+ char namebuf[30];
+ phs_t *phs;
+ SV **svp;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_execute\n"); }
+
+ /*
+ here we get the statement from the statement handle where
+ it has been stored when creating a blank sth during prepare
+ svp = hv_fetch((HV *)SvRV(sth), "Statement", 9, FALSE);
+ statement = SvPV(*svp, na);
+ */
+
+ if (NULL == imp_dbh->conn) {
+ pg_error(sth, -1, "execute on disconnected handle");
+ return -2;
+ }
+
+ statement = imp_sth->statement;
+ if (! statement) {
+ /* are we prepared ? */
+ pg_error(sth, -1, "statement not prepared\n");
+ return -2;
+ }
+
+ /* do we have input parameters ? */
+ if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) {
+ /*
+ we have to allocate some additional memory for possible escaping
+ quotes and backslashes:
+ max_len = length of statement
+ + total length of all params allowing for worst case all
+ characters binary-escaped (\\xxx)
+ + null terminator
+ Note: parameters look like :p1 at this point, so there's no
+ need to explicitly allow for surrounding quotes because '' is
+ shorter than :p1
+ */
+ int max_len = strlen(imp_sth->statement) + imp_sth->all_params_len * 5 + 1;
+ statement = (char*)safemalloc( max_len );
+ dest = statement;
+ src = imp_sth->statement;
+ /* scan statement for ':p1' style placeholders */
+ while(*src) {
+
+ if (in_comment) {
+ /* SQL-style and C++-style */
+ if ((in_comment == '-' || in_comment == '/') && *src == '\n') {
+ in_comment = '\0';
+ }
+ /* C-style */
+ else if (in_comment == '*' && *src == '*' && *(src+1) == '/') {
+ *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
+ in_comment = '\0';
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ if (in_literal) {
+ /* check if literal ends but keep quotes in literal */
+ if (*src == in_literal) {
+ int bs=0;
+ char *str;
+ str = src-1;
+ while (*(str-bs) == '\\')
+ bs++;
+ if (!(bs & 1))
+ in_literal = 0;
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* Look for comments: SQL-style or C++-style or C-style */
+ if ((*src == '-' && *(src+1) == '-') ||
+ (*src == '/' && *(src+1) == '/') ||
+ (*src == '/' && *(src+1) == '*'))
+ {
+ in_comment = *(src+1);
+ /* We know *src & the next char are to be copied, so do */
+ /* it. In the case of C-style comments, it happens to */
+ /* help us avoid slash-asterisk-slash oddities. */
+ *dest++ = *src++;
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* check if no placeholders */
+ if (*src != ':' && *src != '?') {
+ if (*src == '\'' || *src == '"') {
+ in_literal = *src;
+ }
+ *dest++ = *src++;
+ continue;
+ }
+
+ /* check for cast operator */
+ if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) {
+ *dest++ = *src++;
+ continue;
+ }
+
+
+ i = 0;
+ namebuf[i++] = *src++; /* ':' */
+ namebuf[i++] = *src++; /* 'p' */
+
+ while (isDIGIT(*src) && i < (sizeof(namebuf)-1) ) {
+ namebuf[i++] = *src++;
+ }
+ if ( i == (sizeof(namebuf) - 1)) {
+ pg_error(sth, -1, "namebuf buffer overrun\n");
+ return -2;
+ }
+ namebuf[i] = '\0';
+ svp = hv_fetch(imp_sth->all_params_hv, namebuf, i, 0);
+ if (svp == NULL) {
+ pg_error(sth, -1, "parameter unknown\n");
+ return -2;
+ }
+ /* get attribute */
+ phs = (phs_t*)(void*)SvPVX(*svp);
+ /* replace undef with NULL */
+ if(!SvOK(phs->sv)) {
+ val = "NULL";
+ len = 4;
+ } else {
+ val = SvPV(phs->sv, len);
+ }
+ /* quote string attribute */
+ if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */
+ *dest++ = '\'';
+ }
+ while (len--) {
+ if (imp_dbh->pg_auto_escape) {
+ /* if the parameter was bound as PG_BYTEA, escape nonprintables */
+ if (phs->ftype == 17 && !isPRINT(*val)) { /* escape null character */
+ dest+=snprintf(dest, (statement + max_len) - dest, "\\\\%03o", *((unsigned char *)val));
+ if (dest > statement + max_len) {
+ pg_error(sth, -1, "statement buffer overrun\n");
+ return -2;
+ }
+ val++;
+ continue; /* do not copy the null */
+ }
+ /* escape quote */
+ if (*val == '\'') {
+ *dest++ = '\'';
+ }
+ /* escape backslash */
+ if (*val == '\\') {
+ if (phs->ftype == 17) { /* four backslashes. really. */
+ *dest++ = '\\';
+ *dest++ = '\\';
+ *dest++ = '\\';
+ } else {
+ *dest++ = '\\';
+ }
+ }
+ }
+ /* copy attribute to statement */
+ *dest++ = *val++;
+ }
+ /* quote string attribute */
+ if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */
+ *dest++ = '\'';
+ }
+ }
+ *dest = '\0';
+ }
+
+ if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_st_execute: statement = >%s<\n", statement); }
+
+ /* clear old result (if any) */
+ if (imp_sth->result) {
+ PQclear(imp_sth->result);
+ }
+
+ /* execute statement */
+ imp_sth->result = PQexec(imp_dbh->conn, statement);
+
+ /* free statement string in case of input parameters */
+ if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) {
+ Safefree(statement);
+ }
+
+ /* check status */
+ status = imp_sth->result ? PQresultStatus(imp_sth->result) : -1;
+ cmdStatus = imp_sth->result ? (char *)PQcmdStatus(imp_sth->result) : "";
+ cmdTuples = imp_sth->result ? (char *)PQcmdTuples(imp_sth->result) : "";
+
+ if (PGRES_TUPLES_OK == status) {
+ /* select statement */
+ num_fields = PQnfields(imp_sth->result);
+ imp_sth->cur_tuple = 0;
+ DBIc_NUM_FIELDS(imp_sth) = num_fields;
+ DBIc_ACTIVE_on(imp_sth);
+ ret = PQntuples(imp_sth->result);
+ } else if (PGRES_COMMAND_OK == status) {
+ /* non-select statement */
+ if (! strncmp(cmdStatus, "DELETE", 6) || ! strncmp(cmdStatus, "INSERT", 6) || ! strncmp(cmdStatus, "UPDATE", 6)) {
+ ret = atoi(cmdTuples);
+ } else {
+ ret = -1;
+ }
+ } else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status) {
+ /* Copy Out/In data transfer in progress */
+ ret = -1;
+ } else {
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ ret = -2;
+ }
+
+ /* store the number of affected rows */
+ imp_sth->rows = ret;
+
+ return ret;
+}
+
+
+int
+is_high_bit_set(val)
+ char *val;
+{
+ while (*val++)
+ if (*val & 0x80) return 1;
+ return 0;
+}
+
+AV *
+dbd_st_fetch (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ D_imp_dbh_from_sth;
+ int num_fields;
+ int i;
+ AV *av;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_fetch\n"); }
+
+ /* Check that execute() was executed sucessfully */
+ if ( !DBIc_ACTIVE(imp_sth) ) {
+ pg_error(sth, 1, "no statement executing\n");
+
+ return Nullav;
+ }
+
+ if ( imp_sth->cur_tuple == PQntuples(imp_sth->result) ) {
+ imp_sth->cur_tuple = 0;
+ DBIc_ACTIVE_off(imp_sth);
+ return Nullav; /* we reached the last tuple */
+ }
+
+ av = DBIS->get_fbav(imp_sth);
+ num_fields = AvFILL(av)+1;
+
+ for(i = 0; i < num_fields; ++i) {
+
+ SV *sv = AvARRAY(av)[i];
+ if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)) {
+ sv_setsv(sv, &sv_undef);
+ } else {
+ char *val = (char*)PQgetvalue(imp_sth->result, imp_sth->cur_tuple, i);
+ int val_len = strlen(val);
+ int type = PQftype(imp_sth->result, i); /* hopefully these hard coded values will not change */
+ if (16 == type && ! imp_dbh->pg_bool_tf) {
+ *val = (*val == 'f') ? '0' : '1'; /* bool: translate postgres into perl */
+ }
+ if (17 == type) { /* decode \001 -> chr(1), etc, in-place */
+ char *p = val; /* points to next available pos */
+ char *s = val; /* points to current scanning pos */
+ int c1,c2,c3;
+ while (*s) {
+ if (*s == '\\') {
+ if (*(s+1) == '\\') { /* double backslash */
+ *p++ = '\\';
+ s += 2;
+ continue;
+ }
+ else if ( isdigit(c1=(*(s+1))) &&
+ isdigit(c2=(*(s+2))) &&
+ isdigit(c3=(*(s+3))) ) {
+ *p++ = (c1 - '0') * 64 + (c2 - '0') * 8 + (c3 - '0');
+ s += 4;
+ continue;
+ }
+ }
+ *p++ = *s++;
+ }
+ val_len = (p - val);
+ }
+ else if (1042 == type && DBIc_has(imp_sth,DBIcf_ChopBlanks)) {
+ char *str = val;
+ while((val_len > 0) && (str[val_len-1] == ' ')) {
+ val_len--;
+ }
+ val[val_len] = '\0';
+ }
+ sv_setpvn(sv, val, val_len);
+#ifdef SvUTF8_off
+ if (imp_dbh->pg_enable_utf8) {
+ SvUTF8_off(sv);
+ /* XXX Is this all the character data types? */
+ if (18 == type || 25 == type || 1042 ==type || 1043 == type) {
+ if (is_high_bit_set(val) && is_utf8_string(val, val_len))
+ SvUTF8_on(sv);
+ }
+ }
+#endif
+ }
+ }
+
+ imp_sth->cur_tuple += 1;
+
+ return av;
+}
+
+
+int
+dbd_st_blob_read (sth, imp_sth, lobjId, offset, len, destrv, destoffset)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ int lobjId;
+ long offset;
+ long len;
+ SV *destrv;
+ long destoffset;
+{
+ D_imp_dbh_from_sth;
+ int ret, lobj_fd, nbytes, nread;
+ PGresult* result;
+ ExecStatusType status;
+ SV *bufsv;
+ char *tmp;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_blob_read\n"); }
+ /* safety check */
+ if (lobjId <= 0) {
+ pg_error(sth, -1, "dbd_st_blob_read: lobjId <= 0");
+ return 0;
+ }
+ if (offset < 0) {
+ pg_error(sth, -1, "dbd_st_blob_read: offset < 0");
+ return 0;
+ }
+ if (len < 0) {
+ pg_error(sth, -1, "dbd_st_blob_read: len < 0");
+ return 0;
+ }
+ if (! SvROK(destrv)) {
+ pg_error(sth, -1, "dbd_st_blob_read: destrv not a reference");
+ return 0;
+ }
+ if (destoffset < 0) {
+ pg_error(sth, -1, "dbd_st_blob_read: destoffset < 0");
+ return 0;
+ }
+
+ /* dereference destination and ensure it's writable string */
+ bufsv = SvRV(destrv);
+ if (! destoffset) {
+ sv_setpvn(bufsv, "", 0);
+ }
+
+ /* execute begin
+ result = PQexec(imp_dbh->conn, "begin");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+ */
+
+ /* open large object */
+ lobj_fd = lo_open(imp_dbh->conn, lobjId, INV_READ);
+ if (lobj_fd < 0) {
+ pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ /* seek on large object */
+ if (offset > 0) {
+ ret = lo_lseek(imp_dbh->conn, lobj_fd, offset, SEEK_SET);
+ if (ret < 0) {
+ pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+ }
+
+ /* read from large object */
+ nread = 0;
+ SvGROW(bufsv, destoffset + nread + BUFSIZ + 1);
+ tmp = (SvPVX(bufsv)) + destoffset + nread;
+ while ((nbytes = lo_read(imp_dbh->conn, lobj_fd, tmp, BUFSIZ)) > 0) {
+ nread += nbytes;
+ /* break if user wants only a specified chunk */
+ if (len > 0 && nread > len) {
+ nread = len;
+ break;
+ }
+ SvGROW(bufsv, destoffset + nread + BUFSIZ + 1);
+ tmp = (SvPVX(bufsv)) + destoffset + nread;
+ }
+
+ /* terminate string */
+ SvCUR_set(bufsv, destoffset + nread);
+ *SvEND(bufsv) = '\0';
+
+ /* close large object */
+ ret = lo_close(imp_dbh->conn, lobj_fd);
+ if (ret < 0) {
+ pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+
+ /* execute end
+ result = PQexec(imp_dbh->conn, "end");
+ status = result ? PQresultStatus(result) : -1;
+ PQclear(result);
+ if (status != PGRES_COMMAND_OK) {
+ pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
+ return 0;
+ }
+ */
+
+ return nread;
+}
+
+
+int
+dbd_st_rows (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rows\n"); }
+
+ return imp_sth->rows;
+}
+
+
+int
+dbd_st_finish (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ dTHR;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_finish\n"); }
+
+ if (DBIc_ACTIVE(imp_sth) && imp_sth->result) {
+ PQclear(imp_sth->result);
+ imp_sth->result = 0;
+ imp_sth->rows = 0;
+ }
+
+ DBIc_ACTIVE_off(imp_sth);
+ return 1;
+}
+
+
+void
+dbd_st_destroy (sth, imp_sth)
+ SV *sth;
+ imp_sth_t *imp_sth;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_destroy\n"); }
+
+ /* Free off contents of imp_sth */
+
+ Safefree(imp_sth->statement);
+ if (imp_sth->result) {
+ PQclear(imp_sth->result);
+ imp_sth->result = 0;
+ }
+
+ if (imp_sth->out_params_av)
+ sv_free((SV*)imp_sth->out_params_av);
+
+ if (imp_sth->all_params_hv) {
+ HV *hv = imp_sth->all_params_hv;
+ SV *sv;
+ char *key;
+ I32 retlen;
+ hv_iterinit(hv);
+ while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) {
+ if (sv != &sv_undef) {
+ phs_t *phs_tpl = (phs_t*)(void*)SvPVX(sv);
+ sv_free(phs_tpl->sv);
+ }
+ }
+ sv_free((SV*)imp_sth->all_params_hv);
+ }
+
+ DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
+}
+
+
+int
+dbd_st_STORE_attrib (sth, imp_sth, keysv, valuesv)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *keysv;
+ SV *valuesv;
+{
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_STORE\n"); }
+
+ return FALSE;
+}
+
+
+SV *
+dbd_st_FETCH_attrib (sth, imp_sth, keysv)
+ SV *sth;
+ imp_sth_t *imp_sth;
+ SV *keysv;
+{
+ STRLEN kl;
+ char *key = SvPV(keysv,kl);
+ int i, sz;
+ SV *retsv = Nullsv;
+
+ if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_FETCH\n"); }
+
+ if (! imp_sth->result) {
+ return Nullsv;
+ }
+
+ i = DBIc_NUM_FIELDS(imp_sth);
+
+ if (kl == 4 && strEQ(key, "NAME")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ av_store(av, i, newSVpv(PQfname(imp_sth->result, i),0));
+ }
+ } else if ( kl== 4 && strEQ(key, "TYPE")) {
+ /* Need to convert the Pg type to ANSI/SQL type. */
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ av_store(av, i, newSViv(sql_pg_type( imp_sth,
+ PQfname(imp_sth->result, i),
+ PQftype(imp_sth->result, i))));
+ }
+ } else if (kl==9 && strEQ(key, "PRECISION")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ sz = PQfsize(imp_sth->result, i);
+ av_store(av, i, sz > 0 ? newSViv(sz) : &sv_undef);
+ }
+ } else if (kl==5 && strEQ(key, "SCALE")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ av_store(av, i, &sv_undef);
+ }
+ } else if (kl==8 && strEQ(key, "NULLABLE")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ av_store(av, i, newSViv(2));
+ }
+ } else if (kl==10 && strEQ(key, "CursorName")) {
+ retsv = &sv_undef;
+ } else if (kl==11 && strEQ(key, "RowsInCache")) {
+ retsv = &sv_undef;
+ } else if (kl==7 && strEQ(key, "pg_size")) {
+ AV *av = newAV();
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ av_store(av, i, newSViv(PQfsize(imp_sth->result, i)));
+ }
+ } else if (kl==7 && strEQ(key, "pg_type")) {
+ AV *av = newAV();
+ char *type_nam;
+ retsv = newRV(sv_2mortal((SV*)av));
+ while(--i >= 0) {
+ switch (PQftype(imp_sth->result, i)) {
+ case 16:
+ type_nam = "bool";
+ break;
+ case 17:
+ type_nam = "bytea";
+ break;
+ case 18:
+ type_nam = "char";
+ break;
+ case 19:
+ type_nam = "name";
+ break;
+ case 20:
+ type_nam = "int8";
+ break;
+ case 21:
+ type_nam = "int2";
+ break;
+ case 22:
+ type_nam = "int28";
+ break;
+ case 23:
+ type_nam = "int4";
+ break;
+ case 24:
+ type_nam = "regproc";
+ break;
+ case 25:
+ type_nam = "text";
+ break;
+ case 26:
+ type_nam = "oid";
+ break;
+ case 27:
+ type_nam = "tid";
+ break;
+ case 28:
+ type_nam = "xid";
+ break;
+ case 29:
+ type_nam = "cid";
+ break;
+ case 30:
+ type_nam = "oid8";
+ break;
+ case 32:
+ type_nam = "SET";
+ break;
+ case 210:
+ type_nam = "smgr";
+ break;
+ case 600:
+ type_nam = "point";
+ break;
+ case 601:
+ type_nam = "lseg";
+ break;
+ case 602:
+ type_nam = "path";
+ break;
+ case 603:
+ type_nam = "box";
+ break;
+ case 604:
+ type_nam = "polygon";
+ break;
+ case 605:
+ type_nam = "filename";
+ break;
+ case 628:
+ type_nam = "line";
+ break;
+ case 629:
+ type_nam = "_line";
+ break;
+ case 700:
+ type_nam = "float4";
+ break;
+ case 701:
+ type_nam = "float8";
+ break;
+ case 702:
+ type_nam = "abstime";
+ break;
+ case 703:
+ type_nam = "reltime";
+ break;
+ case 704:
+ type_nam = "tinterval";
+ break;
+ case 705:
+ type_nam = "unknown";
+ break;
+ case 718:
+ type_nam = "circle";
+ break;
+ case 719:
+ type_nam = "_circle";
+ break;
+ case 790:
+ type_nam = "money";
+ break;
+ case 791:
+ type_nam = "_money";
+ break;
+ case 810:
+ type_nam = "oidint2";
+ break;
+ case 910:
+ type_nam = "oidint4";
+ break;
+ case 911:
+ type_nam = "oidname";
+ break;
+ case 1000:
+ type_nam = "_bool";
+ break;
+ case 1001:
+ type_nam = "_bytea";
+ break;
+ case 1002:
+ type_nam = "_char";
+ break;
+ case 1003:
+ type_nam = "_name";
+ break;
+ case 1005:
+ type_nam = "_int2";
+ break;
+ case 1006:
+ type_nam = "_int28";
+ break;
+ case 1007:
+ type_nam = "_int4";
+ break;
+ case 1008:
+ type_nam = "_regproc";
+ break;
+ case 1009:
+ type_nam = "_text";
+ break;
+ case 1028:
+ type_nam = "_oid";
+ break;
+ case 1010:
+ type_nam = "_tid";
+ break;
+ case 1011:
+ type_nam = "_xid";
+ break;
+ case 1012:
+ type_nam = "_cid";
+ break;
+ case 1013:
+ type_nam = "_oid8";
+ break;
+ case 1014:
+ type_nam = "_lock";
+ break;
+ case 1015:
+ type_nam = "_stub";
+ break;
+ case 1016:
+ type_nam = "_ref";
+ break;
+ case 1017:
+ type_nam = "_point";
+ break;
+ case 1018:
+ type_nam = "_lseg";
+ break;
+ case 1019:
+ type_nam = "_path";
+ break;
+ case 1020:
+ type_nam = "_box";
+ break;
+ case 1021:
+ type_nam = "_float4";
+ break;
+ case 1022:
+ type_nam = "_float8";
+ break;
+ case 1023:
+ type_nam = "_abstime";
+ break;
+ case 1024:
+ type_nam = "_reltime";
+ break;
+ case 1025:
+ type_nam = "_tinterval";
+ break;
+ case 1026:
+ type_nam = "_filename";
+ break;
+ case 1027:
+ type_nam = "_polygon";
+ break;
+ case 1033:
+ type_nam = "aclitem";
+ break;
+ case 1034:
+ type_nam = "_aclitem";
+ break;
+ case 1042:
+ type_nam = "bpchar";
+ break;
+ case 1043:
+ type_nam = "varchar";
+ break;
+ case 1082:
+ type_nam = "date";
+ break;
+ case 1083:
+ type_nam = "time";
+ break;
+ case 1182:
+ type_nam = "_date";
+ break;
+ case 1183:
+ type_nam = "_time";
+ break;
+ case 1184:
+ type_nam = "datetime";
+ break;
+ case 1185:
+ type_nam = "_datetime";
+ break;
+ case 1186:
+ type_nam = "timespan";
+ break;
+ case 1187:
+ type_nam = "_timespan";
+ break;
+ case 1231:
+ type_nam = "_numeric";
+ break;
+ case 1296:
+ type_nam = "timestamp";
+ break;
+ case 1700:
+ type_nam = "numeric";
+ break;
+
+ default:
+ type_nam = "unknown";
+
+ }
+ av_store(av, i, newSVpv(type_nam, 0));
+ }
+ } else if (kl==13 && strEQ(key, "pg_oid_status")) {
+ retsv = newSVpv((char *)PQoidStatus(imp_sth->result), 0);
+ } else if (kl==13 && strEQ(key, "pg_cmd_status")) {
+ retsv = newSVpv((char *)PQcmdStatus(imp_sth->result), 0);
+ } else {
+ return Nullsv;
+ }
+
+ return sv_2mortal(retsv);
+}
+
+
+/* end of dbdimp.c */
--- /dev/null
+/*
+ $Id: dbdimp.h,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+ Copyright (c) 1997,1998,1999,2000 Edmund Mergl
+ Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
+
+ You may distribute under the terms of either the GNU General Public
+ License or the Artistic License, as specified in the Perl README file.
+*/
+
+#ifdef WIN32
+#define snprintf _snprintf
+#endif
+
+/* Define drh implementor data structure */
+struct imp_drh_st {
+ dbih_drc_t com; /* MUST be first element in structure */
+};
+
+/* Define dbh implementor data structure */
+struct imp_dbh_st {
+ dbih_dbc_t com; /* MUST be first element in structure */
+
+ PGconn * conn; /* connection structure */
+ int init_commit; /* initialize AutoCommit */
+ int pg_auto_escape; /* initialize AutoEscape */
+ int pg_bool_tf; /* do bools return 't'/'f' */
+#ifdef SvUTF8_off
+ int pg_enable_utf8; /* should we attempt to make utf8 strings? */
+#endif
+};
+
+/* Define sth implementor data structure */
+struct imp_sth_st {
+ dbih_stc_t com; /* MUST be first element in structure */
+
+ PGresult* result; /* result structure */
+ int cur_tuple; /* current tuple */
+ int rows; /* number of affected rows */
+
+ /* Input Details */
+ char *statement; /* sql (see sth_scan) */
+ HV *all_params_hv; /* all params, keyed by name */
+ AV *out_params_av; /* quick access to inout params */
+ int pg_pad_empty; /* convert ""->" " when binding */
+ int all_params_len; /* length-sum of all params */
+
+ /* (In/)Out Parameter Details */
+ bool has_inout_params;
+};
+
+
+#define sword signed int
+#define sb2 signed short
+#define ub2 unsigned short
+
+typedef struct phs_st phs_t; /* scalar placeholder */
+
+struct phs_st { /* scalar placeholder EXPERIMENTAL */
+ sword ftype; /* external OCI field type */
+
+ SV *sv; /* the scalar holding the value */
+ int sv_type; /* original sv type at time of bind */
+ bool is_inout;
+
+ IV maxlen; /* max possible len (=allocated buffer) */
+
+ /* these will become an array */
+ sb2 indp; /* null indicator */
+ char *progv;
+ ub2 arcode;
+ IV alen; /* effective length ( <= maxlen ) */
+
+ int alen_incnull; /* 0 or 1 if alen should include null */
+ char name[1]; /* struct is malloc'd bigger as needed */
+};
+
+
+SV * dbd_db_pg_notifies (SV *dbh, imp_dbh_t *imp_dbh);
+
+/* end of dbdimp.h */
--- /dev/null
+#!/usr/local/bin/perl
+
+# $Id: ApacheDBI.pl,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+# don't forget to create in postgres the user who is running
+# the httpd, eg 'createuser nobody' !
+#
+# demo script, tested with:
+# - PostgreSQL-7.1.1
+# - apache_1.3.12
+# - mod_perl-1.23
+# - perl5.6.0
+# - DBI-1.14
+
+use CGI;
+use DBI;
+use strict;
+
+my $query = new CGI;
+
+print $query->header,
+ $query->start_html(-title=>'A Simple Example'),
+ $query->startform,
+ "<CENTER><H3>Testing Module DBI</H3></CENTER>",
+ "<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>",
+ "<TR><TD>Enter the data source: </TD>",
+ "<TD>", $query->textfield(-name=>'data_source', -size=>40, -default=>'dbi:Pg:dbname=template1'), "</TD>",
+ "</TR>",
+ "<TR><TD>Enter the user name: </TD>",
+ "<TD>", $query->textfield(-name=>'username'), "</TD>",
+ "</TR>",
+ "<TR><TD>Enter the password: </TD>",
+ "<TD>", $query->textfield(-name=>'auth'), "</TD>",
+ "</TR>",
+ "<TR><TD>Enter the select command: </TD>",
+ "<TD>", $query->textfield(-name=>'cmd', -size=>40), "</TD>",
+ "</TR>",
+ "</TABLE></CENTER><P>",
+ "<CENTER>", $query->submit(-value=>'Submit'), "</CENTER>",
+ $query->endform;
+
+if ($query->param) {
+
+ my $data_source = $query->param('data_source');
+ my $username = $query->param('username');
+ my $auth = $query->param('auth');
+ my $cmd = $query->param('cmd');
+ my $dbh = DBI->connect($data_source, $username, $auth);
+ if ($dbh) {
+ my $sth = $dbh->prepare($cmd);
+ my $ret = $sth->execute;
+ if ($ret) {
+ my($i, $ary_ref);
+ print "<P><CENTER><TABLE CELLPADDING=4 CELLSPACING=2 BORDER=1>\n";
+ while ($ary_ref = $sth->fetchrow_arrayref) {
+ print "<TR><TD>", join("</TD><TD>", @$ary_ref), "</TD></TR>\n";
+ }
+ print "</TABLE></CENTER><P>\n";
+ $sth->finish;
+ } else {
+ print "<CENTER><H2>", $DBI::errstr, "</H2></CENTER>\n";
+ }
+ $dbh->disconnect;
+ } else {
+ print "<CENTER><H2>", $DBI::errstr, "</H2></CENTER>\n";
+ }
+}
+
+print $query->end_html;
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+use DBI;
+use DBD::Pg;
+
+my $dsn = "dbname=p1";
+my $dbh = DBI->connect('dbi:Pg:dbname=p1', undef, undef, { AutoCommit => 1 });
+
+my $buf = 'abcdefghijklmnopqrstuvwxyz' x 400;
+
+my $id = write_blob($dbh, undef, $buf);
+
+my $dat = read_blob($dbh, $id);
+
+print "Done\n";
+
+sub write_blob {
+ my ($dbh, $lobj_id, $data) = @_;
+
+ # begin transaction
+ $dbh->{AutoCommit} = 0;
+
+ # Create a new lo if we are not passed an lo object ID.
+ unless ($lobj_id) {
+ # Create the object.
+ $lobj_id = $dbh->func($dbh->{'pg_INV_WRITE'}, 'lo_creat');
+ }
+
+ # Open it to get a file descriptor.
+ my $lobj_fd = $dbh->func($lobj_id, $dbh->{'pg_INV_WRITE'}, 'lo_open');
+
+ $dbh->func($lobj_fd, 0, 0, 'lo_lseek');
+
+ # Write some data to it.
+ my $len = $dbh->func($lobj_fd, $data, length($data), 'lo_write');
+
+ die "Errors writing lo\n" if $len != length($data);
+
+ # Close 'er up.
+ $dbh->func($lobj_fd, 'lo_close') or die "Problems closing lo object\n";
+
+ # end transaction
+ $dbh->{AutoCommit} = 1;
+
+ return $lobj_id;
+}
+
+sub read_blob {
+ my ($dbh, $lobj_id) = @_;
+ my $data = '';
+ my $read_len = 256;
+ my $chunk = '';
+
+ # begin transaction
+ $dbh->{AutoCommit} = 0;
+
+ my $lobj_fd = $dbh->func($lobj_id, $dbh->{'pg_INV_READ'}, 'lo_open');
+
+ $dbh->func($lobj_fd, 0, 0, 'lo_lseek');
+
+ # Pull out all the data.
+ while ($dbh->func($lobj_fd, $chunk, $read_len, 'lo_read')) {
+ $data .= $chunk;
+ }
+
+ $dbh->func($lobj_fd, 'lo_close') or die "Problems closing lo object\n";
+
+ # end transaction
+ $dbh->{AutoCommit} = 1;
+
+ return $data;
+}
--- /dev/null
+diff -r --unified DBD-Pg-1.00/test.pl DBD-Pg-1.00.alex/test.pl
+--- DBD-Pg-1.00/test.pl Sun May 27 10:10:13 2001
++++ DBD-Pg-1.00.alex/test.pl Sun Jun 10 15:38:09 2001
+@@ -40,7 +40,7 @@
+ my $dsn_main = "dbi:Pg:dbname=$dbmain";
+ my $dsn_test = "dbi:Pg:dbname=$dbtest";
+
+-my ($dbh0, $dbh, $sth);
++my ($dbh0, $dbh, $dbh1, $sth);
+
+ #DBI->trace(3); # make your choice
+
+@@ -445,16 +445,56 @@
+ # end transaction
+ $dbh->{AutoCommit} = 1;
+
++# compare large objects
++
+ ( $dbh->func($lobjId, 'lo_unlink') )
+ and print "\$dbh->func(lo_unlink) ...... ok\n"
+ or print "\$dbh->func(lo_unlink) ...... not ok\n";
+
+-# compare large objects
+-
+ ( $pgin cmp $buf and $pgin cmp $blob )
+ and print "compare blobs .............. not ok\n"
+ or print "compare blobs .............. ok\n";
+
++my $fd;
++( $fd=$dbh->func( 'getfd') )
++ and print "\$dbh->func(getfd) .......... ok\n"
++ or print "\$dbh->func(getfd) .......... not ok\n";
++
++( $dbh->do( 'LISTEN test ') )
++ and print "\$dbh->do('LISTEN test') .... ok\n"
++ or print "\$dbh->do('LISTEN test') .... not ok\n";
++
++( $dbh1 = DBI->connect("$dsn_test", '', '', { AutoCommit => 1 }) )
++ and print "DBI->connect (for notify)... ok\n"
++ or die "DBI->connect (for notify)... not ok: ", $DBI::errstr;
++
++# there should be no data for read on $fd , until we send a notify
++
++ my $rout;
++ my $rin = '';
++ vec($rin,$fd,1) = 1;
++ my $nfound = select( $rout=$rin, undef, undef, 0);
++
++( $nfound==0 )
++ and print "select(\$fd) returns no data. ok\n"
++ or die "select(\$fd) returns no data. not ok\n";
++
++( $dbh1->do( 'NOTIFY test ') )
++ and print "\$dbh1->do('NOTIFY test') ... ok\n"
++ or print "\$dbh1->do('NOTIFY test') ... not ok\n";
++
++ my $nfound = select( $rout=$rin, undef, undef, 1);
++
++( $nfound==1 )
++ and print "select(\$fd) returns data.... ok\n"
++ or die "select(\$fd) returns data.... not ok\n";
++
++my $notify_r;
++
++( $notify_r = $dbh->func('notifies') )
++ and print "\$dbh->func('notifies')...... ok\n"
++ or die "\$dbh->func('notifies')...... not ok\n";
++
+ ######################### disconnect and drop test database
+
+ # disconnect
+@@ -462,6 +502,10 @@
+ ( $dbh->disconnect )
+ and print "\$dbh->disconnect ........... ok\n"
+ or die "\$dbh->disconnect ........... not ok: ", $DBI::errstr;
++
++( $dbh1->disconnect )
++ and print "\$dbh1->disconnect .......... ok\n"
++ or die "\$dbh1->disconnect .......... not ok: ", $DBI::errstr;
+
+ $dbh0->do("DROP DATABASE $dbtest");
+ $dbh0->disconnect;
--- /dev/null
+print "1..1\n";
+
+use DBI;
+use DBD::Pg;
+
+if ($DBD::Pg::VERSION) {
+ print "ok 1\n";
+} else {
+ print "not ok 1\n";
+}
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 2;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+
+ok((defined $dbh and $dbh->disconnect()),
+ 'connect with transaction'
+ );
+
+undef $dbh;
+$dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 1});
+
+ok((defined $dbh and $dbh->disconnect()),
+ 'connect without transaction'
+ );
+
--- /dev/null
+use strict;
+use Test::More tests => 20;
+
+use DBD::Pg qw(:pg_types);
+
+ok(PG_BOOL == 16, 'PG_BOOL');
+ok(PG_BYTEA == 17, 'PG_BYTEA');
+ok(PG_CHAR == 18, 'PG_CHAR');
+ok(PG_INT8 == 20, 'PG_INT8');
+ok(PG_INT2 == 21, 'PG_INT2');
+ok(PG_INT4 == 23, 'PG_INT4');
+ok(PG_TEXT == 25, 'PG_TEXT');
+ok(PG_OID == 26, 'PG_OID');
+ok(PG_FLOAT4 == 700, 'PG_FLOAT4');
+ok(PG_FLOAT8 == 701, 'PG_FLOAT8');
+ok(PG_ABSTIME == 702, 'PG_ABSTIME');
+ok(PG_RELTIME == 703, 'PG_RELTIME');
+ok(PG_TINTERVAL == 704, 'PG_TINTERVAL');
+ok(PG_BPCHAR == 1042, 'PG_BPCHAR');
+ok(PG_VARCHAR == 1043, 'PG_VARCHAR');
+ok(PG_DATE == 1082, 'PG_DATE');
+ok(PG_TIME == 1083, 'PG_TIME');
+ok(PG_DATETIME == 1184, 'PG_DATETIME');
+ok(PG_TIMESPAN == 1186, 'PG_TIMESPAN');
+ok(PG_TIMESTAMP == 1296, 'PG_TIMESTAMP');
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 1});
+ok(defined $dbh,'connect without transaction');
+{
+ local $dbh->{PrintError} = 0;
+ local $dbh->{RaiseError} = 0;
+ $dbh->do(q{DROP TABLE test});
+}
+
+my $sql = <<SQL;
+CREATE TABLE test (
+ id int,
+ name text,
+ val text,
+ score float,
+ date timestamp default 'now()',
+ array text[][]
+)
+SQL
+
+ok($dbh->do($sql),
+ 'create table'
+ );
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
+
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 8;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+my $sql = <<SQL;
+ SELECT *
+ FROM test
+SQL
+
+ok($dbh->prepare($sql),
+ "prepare: $sql"
+ );
+
+$sql = <<SQL;
+ SELECT id
+ FROM test
+SQL
+
+ok($dbh->prepare($sql),
+ "prepare: $sql"
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+SQL
+
+ok($dbh->prepare($sql),
+ "prepare: $sql"
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = 1
+SQL
+
+ok($dbh->prepare($sql),
+ "prepare: $sql"
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+SQL
+
+ok($dbh->prepare($sql),
+ "prepare: $sql"
+ );
+
+$sql = <<SQL;
+ SELECT *
+ FROM test
+ WHERE id = ?
+ AND name = ?
+ AND value = ?
+ AND score = ?
+ and data = ?
+SQL
+
+ok($dbh->prepare($sql),
+ "prepare: $sql"
+ );
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 11;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+my $sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+SQL
+my $sth = $dbh->prepare($sql);
+ok(defined $sth,
+ "prepare: $sql"
+ );
+
+ok($sth->bind_param(1, 'foo'),
+ 'bind int column with string'
+ );
+
+ok($sth->bind_param(1, 1),
+ 'rebind int column with int'
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+ AND name = ?
+SQL
+$sth = $dbh->prepare($sql);
+ok(defined $sth,
+ "prepare: $sql"
+ );
+
+ok($sth->bind_param(1, 'foo'),
+ 'bind int column with string',
+ );
+ok($sth->bind_param(2, 'bar'),
+ 'bind string column with text'
+ );
+ok($sth->bind_param(2, 'baz'),
+ 'rebind string column with text'
+ );
+
+ok($sth->finish(),
+ 'finish'
+ );
+
+# Make sure that we get warnings when we try to use SQL_BINARY.
+{
+ local $SIG{__WARN__} =
+ sub { ok($_[0] =~ /^Use of SQL type SQL_BINARY/,
+ 'warning with SQL_BINARY'
+ );
+ };
+
+ $sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+ AND name = ?
+SQL
+ $sth = $dbh->prepare($sql);
+
+ $sth->bind_param(1, 'foo', DBI::SQL_BINARY);
+}
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 13;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+my $sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+SQL
+my $sth = $dbh->prepare($sql);
+ok(defined $sth,
+ "prepare: $sql"
+ );
+
+$sth->bind_param(1, 1);
+ok($sth->execute(),
+ 'exectute with one bind param'
+ );
+
+$sth->bind_param(1, 2);
+ok($sth->execute(),
+ 'exectute with rebinding one param'
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+ AND name = ?
+SQL
+$sth = $dbh->prepare($sql);
+ok(defined $sth,
+ "prepare: $sql"
+ );
+
+$sth->bind_param(1, 2);
+$sth->bind_param(2, 'foo');
+ok($sth->execute(),
+ 'exectute with two bind params'
+ );
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth = $dbh->prepare($sql);
+ $sth->bind_param(1, 2);
+ $sth->execute();
+};
+ok(!$@,
+ 'execute with only first of two params bound'
+ );
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth = $dbh->prepare($sql);
+ $sth->bind_param(2, 'foo');
+ $sth->execute();
+};
+ok(!$@,
+ 'execute with only second of two params bound'
+ );
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth = $dbh->prepare($sql);
+ $sth->execute();
+};
+ok(!$@,
+ 'execute with neither of two params bound'
+ );
+
+$sth = $dbh->prepare($sql);
+ok($sth->execute(1, 'foo'),
+ 'execute with both params bound in execute'
+ );
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth = $dbh->prepare(q{
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+ AND name = ?
+ });
+ $sth->execute(1);
+};
+ok($@,
+ 'execute with only one of two params bound in execute'
+ );
+
+
+ok($sth->finish(),
+ 'finish'
+ );
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 10;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+$dbh->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')});
+$dbh->do(q{INSERT INTO test (id, name, val) VALUES (2, 'bar', 'chicken')});
+$dbh->do(q{INSERT INTO test (id, name, val) VALUES (3, 'baz', 'pig')});
+ok($dbh->commit(),
+ 'commit'
+ );
+
+my $sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+SQL
+my $sth = $dbh->prepare($sql);
+$sth->execute();
+
+my $rows = 0;
+while (my ($id, $name) = $sth->fetchrow_array()) {
+ if (defined($id) && defined($name)) {
+ $rows++;
+ }
+}
+$sth->finish();
+ok($rows == 3,
+ 'fetch three rows'
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE 1 = 0
+SQL
+$sth = $dbh->prepare($sql);
+$sth->execute();
+
+$rows = 0;
+while (my ($id, $name) = $sth->fetchrow_array()) {
+ $rows++;
+}
+$sth->finish();
+
+ok($rows == 0,
+ 'fetch zero rows'
+ );
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE id = ?
+SQL
+$sth = $dbh->prepare($sql);
+$sth->execute(1);
+
+$rows = 0;
+while (my ($id, $name) = $sth->fetchrow_array()) {
+ if (defined($id) && defined($name)) {
+ $rows++;
+ }
+}
+$sth->finish();
+
+ok($rows == 1,
+ 'fetch one row on id'
+ );
+
+# Attempt to test whether or not we can get unicode out of the database
+# correctly. Reuse the previous sth.
+SKIP: {
+ eval "use Encode";
+ skip "need Encode module for unicode tests", 3 if $@;
+ local $dbh->{pg_enable_utf8} = 1;
+ $dbh->do("INSERT INTO test (id, name, val) VALUES (4, '\001\000dam', 'cow')");
+ $sth->execute(4);
+ my ($id, $name) = $sth->fetchrow_array();
+ ok(Encode::is_utf8($name),
+ 'returned data has utf8 bit set'
+ );
+ is(length($name), 4,
+ 'returned utf8 data is not corrupted'
+ );
+ $sth->finish();
+ $sth->execute(1);
+ my ($id2, $name2) = $sth->fetchrow_array();
+ ok(! Encode::is_utf8($name2),
+ 'returned ASCII data has not got utf8 bit set'
+ );
+ $sth->finish();
+}
+
+$sql = <<SQL;
+ SELECT id
+ , name
+ FROM test
+ WHERE name = ?
+SQL
+$sth = $dbh->prepare($sql);
+$sth->execute('foo');
+
+$rows = 0;
+while (my ($id, $name) = $sth->fetchrow_array()) {
+ if (defined($id) && defined($name)) {
+ $rows++;
+ }
+}
+$sth->finish();
+
+ok($rows == 1,
+ 'fetch one row on name'
+ );
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
+
+$dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+
+$dbh->disconnect();
+$dbh->disconnect();
+$dbh->disconnect();
+ok($dbh->disconnect(),
+ 'disconnect on already disconnected dbh'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, PrintError => 0, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+my $sth = $dbh->prepare(q{SELECT * FROM test});
+ok($dbh->disconnect(),
+ 'disconnect with un-finished statement'
+ );
+
+eval {
+ $sth->execute();
+};
+ok($@,
+ 'execute on disconnected statement'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 18;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh1 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh1,
+ 'connect first dbh'
+ );
+
+my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh2,
+ 'connect second dbh'
+ );
+
+$dbh1->do(q{DELETE FROM test});
+ok($dbh1->commit(),
+ 'delete'
+ );
+
+my $rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 0,
+ 'fetch on empty table from dbh1'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 0,
+ 'fetch on empty table from dbh2'
+ );
+
+$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')});
+$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (2, 'bar', 'chicken')});
+$dbh1->do(q{INSERT INTO test (id, name, val) VALUES (3, 'baz', 'pig')});
+
+$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 3,
+ 'fetch three rows on dbh1'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 0,
+ 'fetch on dbh2 before commit'
+ );
+
+ok($dbh1->commit(),
+ 'commit work'
+ );
+
+$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 3,
+ 'fetch on dbh1 after commit'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 3,
+ 'fetch on dbh2 after commit'
+ );
+
+ok($dbh1->do(q{DELETE FROM test}),
+ 'delete'
+ );
+
+$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 0,
+ 'fetch on empty table from dbh1'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 3,
+ 'fetch on from dbh2 without commit'
+ );
+
+ok($dbh1->rollback(),
+ 'rollback'
+ );
+
+$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 3,
+ 'fetch on from dbh1 after rollback'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 3,
+ 'fetch on from dbh2 after rollback'
+ );
+
+ok($dbh1->disconnect(),
+ 'disconnect on dbh1'
+);
+
+ok($dbh2->disconnect(),
+ 'disconnect on dbh2'
+);
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 12;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh1 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 1}
+ );
+ok(defined $dbh1,
+ 'connect first dbh'
+ );
+
+my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 1}
+ );
+ok(defined $dbh2,
+ 'connect second dbh'
+ );
+
+ok($dbh1->do(q{DELETE FROM test}),
+ 'delete'
+ );
+
+my $rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 0,
+ 'fetch on empty table from dbh1'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 0,
+ 'fetch on empty table from dbh2'
+ );
+
+ok($dbh1->do(q{INSERT INTO test (id, name, val) VALUES (1, 'foo', 'horse')}),
+ 'insert'
+ );
+
+$rows = ($dbh1->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 1,
+ 'fetch one row from dbh1'
+ );
+
+$rows = ($dbh2->selectrow_array(q{SELECT COUNT(*) FROM test}))[0];
+ok($rows == 1,
+ 'fetch one row from dbh1'
+ );
+
+local $SIG{__WARN__} = sub {};
+ok(!$dbh1->commit(),
+ 'commit'
+ );
+
+ok(!$dbh1->rollback(),
+ 'rollback'
+ );
+
+ok($dbh1->disconnect(),
+ 'disconnect on dbh1'
+);
+
+ok($dbh2->disconnect(),
+ 'disconnect on dbh2'
+);
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 8;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+my %tests = (
+ one=>["'", "'\\" . sprintf("%03o", ord("'")) . "'"],
+ two=>["''", "'" . ("\\" . sprintf("%03o", ord("'")))x2 . "'"],
+ three=>["\\", "'\\" . sprintf("%03o", ord("\\")) . "'"],
+ four=>["\\'", sprintf("'\\%03o\\%03o'", ord("\\"), ord("'"))],
+ five=>["\\'?:", sprintf("'\\%03o\\%03o?:'", ord("\\"), ord("'"))],
+ );
+
+foreach my $test (keys %tests) {
+ my ($unq, $quo, $ref);
+
+ $unq = $tests{$test}->[0];
+ $ref = $tests{$test}->[1];
+ $quo = $dbh->quote($unq);
+
+ ok($quo eq $ref,
+ "$test: $unq -> expected $quo got $ref"
+ );
+}
+
+# Make sure that SQL_BINARY doesn't work.
+# eval { $dbh->quote('foo', { TYPE => DBI::SQL_BINARY })};
+eval {
+ local $dbh->{PrintError} = 0;
+ $dbh->quote('foo', DBI::SQL_BINARY);
+};
+ok($@ && $@ =~ /Use of SQL_BINARY invalid in quote/,
+ 'SQL_BINARY'
+);
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 9;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+my $quo = $dbh->quote("\\'?:");
+my $sth = $dbh->prepare(qq{
+ INSERT INTO test (name) VALUES ($quo)
+ });
+$sth->execute();
+
+my $sql = <<SQL;
+ SELECT name
+ FROM test
+ WHERE name = $quo;
+SQL
+$sth = $dbh->prepare($sql);
+$sth->execute();
+
+my ($retr) = $sth->fetchrow_array();
+ok((defined($retr) && $retr eq "\\'?:"),
+ 'fetch'
+ );
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth->execute('foo');
+};
+ok($@,
+ 'execute with one bind param where none expected'
+ );
+
+$sql = <<SQL;
+ SELECT name
+ FROM test
+ WHERE name = ?
+SQL
+$sth = $dbh->prepare($sql);
+
+$sth->execute("\\'?:");
+
+($retr) = $sth->fetchrow_array();
+ok((defined($retr) && $retr eq "\\'?:"),
+ 'execute with ? placeholder'
+ );
+
+$sql = <<SQL;
+ SELECT name
+ FROM test
+ WHERE name = :1
+SQL
+$sth = $dbh->prepare($sql);
+
+$sth->execute("\\'?:");
+
+($retr) = $sth->fetchrow_array();
+ok((defined($retr) && $retr eq "\\'?:"),
+ 'execute with :1 placeholder'
+ );
+
+$sql = <<SQL;
+ SELECT name
+ FROM test
+ WHERE name = '?'
+SQL
+$sth = $dbh->prepare($sql);
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth->execute('foo');
+};
+ok($@,
+ 'execute with quoted ?'
+ );
+
+$sql = <<SQL;
+ SELECT name
+ FROM test
+ WHERE name = ':1'
+SQL
+$sth = $dbh->prepare($sql);
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $sth->execute('foo');
+};
+ok($@,
+ 'execute with quoted :1'
+ );
+
+$sql = <<SQL;
+ SELECT name
+ FROM test
+ WHERE name = '\\\\'
+ AND name = '?'
+SQL
+$sth = $dbh->prepare($sql);
+
+eval {
+ local $dbh->{PrintError} = 0;
+ local $sth->{PrintError} = 0;
+ $sth->execute('foo');
+};
+ok($@,
+ 'execute with quoted ?'
+ );
+
+$sth->finish();
+$dbh->rollback();
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+eval {
+ local $dbh->{PrintError} = 0;
+ $dbh->do(q{DROP TABLE tt});
+ $dbh->commit();
+};
+$dbh->rollback();
+
+$dbh->do(q{CREATE TABLE tt (blah numeric(5,2), foo text)});
+my $sth = $dbh->prepare(qq{
+ SELECT * FROM tt WHERE FALSE
+ });
+$sth->execute();
+
+my @types = @{$sth->{pg_type}};
+
+ok($types[0] eq 'numeric',
+ 'type numeric'
+ );
+
+ok($types[1] eq 'text',
+ 'type text'
+ );
+
+$sth->finish();
+$dbh->rollback();
+$dbh->disconnect();
--- /dev/null
+#!/usr/bin/perl -w -I./t
+$| = 1;
+
+# vim:ts=2:sw=2:ai:aw:nu:
+use DBI qw(:sql_types);
+use Data::Dumper;
+use strict;
+use Test::More;
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 59;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+#
+# Test the different methods, so are expected to fail.
+#
+
+my $sth;
+
+# foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) {
+# no strict 'refs';
+# printf "%s=%d\n", $_, &{"DBI::$_"};
+# }
+
+my $get_info = {
+ SQL_DBMS_NAME => 17
+ , SQL_DBMS_VER => 18
+ , SQL_IDENTIFIER_QUOTE_CHAR => 29
+ , SQL_CATALOG_NAME_SEPARATOR => 41
+ , SQL_CATALOG_LOCATION => 114
+};
+
+# Ping
+ eval {
+ ok( $dbh->ping(), "Testing Ping" );
+ };
+ok ( !$@, "Ping Tested" );
+
+# Get Info
+ eval {
+ $sth = $dbh->get_info();
+ };
+ok ($@, "Call to get_info with 0 arguements, error expected: $@" );
+$sth = undef;
+
+# Table Info
+ eval {
+ $sth = $dbh->table_info();
+ };
+ok ((!$@ and defined $sth), "table_info tested" );
+$sth = undef;
+
+# Column Info
+ eval {
+ $sth = $dbh->column_info();
+ };
+ok ((!$@ and defined $sth), "column_info tested" );
+#ok ($@, "Call to column_info with 0 arguements, error expected: $@" );
+$sth = undef;
+
+
+# Tables
+ eval {
+ $sth = $dbh->tables();
+ };
+ok ((!$@ and defined $sth), "tables tested" );
+$sth = undef;
+
+# Type Info All
+ eval {
+ $sth = $dbh->type_info_all();
+ };
+ok ((!$@ and defined $sth), "type_info_all tested" );
+$sth = undef;
+
+# Type Info
+ eval {
+ my @types = $dbh->type_info();
+ die unless @types;
+ };
+ok (!$@, "type_info(undef)");
+$sth = undef;
+
+# Quote
+ eval {
+ my $val = $dbh->quote();
+ die unless $val;
+ };
+ok ($@, "quote error expected: $@");
+
+$sth = undef;
+# Tests for quote:
+my @qt_vals = (1, 2, undef, 'NULL', "ThisIsAString", "This is Another String");
+my @expt_vals = (q{'1'}, q{'2'}, "NULL", q{'NULL'}, q{'ThisIsAString'}, q{'This is Another String'});
+for (my $x = 0; $x <= $#qt_vals; $x++) {
+ local $^W = 0;
+ my $val = $dbh->quote( $qt_vals[$x] );
+ is( $val, $expt_vals[$x], "$x: quote on $qt_vals[$x] returned $val" );
+}
+
+is( $dbh->quote( 1, SQL_INTEGER() ), 1, "quote(1, SQL_INTEGER)" );
+
+
+# Quote Identifier
+ eval {
+ my $val = $dbh->quote_identifier();
+ die unless $val;
+ };
+
+ok ($@, "quote_identifier error expected: $@");
+$sth = undef;
+
+SKIP: {
+ skip("get_info() not yet implemented", 1);
+ # , SQL_IDENTIFIER_QUOTE_CHAR => 29
+ # , SQL_CATALOG_NAME_SEPARATOR => 41
+ my $qt = $dbh->get_info( $get_info->{SQL_IDENTIFIER_QUOTE_CHAR} );
+ my $sep = $dbh->get_info( $get_info->{SQL_CATALOG_NAME_SEPARATOR} );
+
+ # Uncomment this line and remove the next line when get_info() is implemented.
+# my $cmp_str = qq{${qt}link${qt}${sep}${qt}schema${qt}${sep}${qt}table${qt}};
+ my $cmp_str = '';
+ is( $dbh->quote_identifier( "link", "schema", "table" )
+ , $cmp_str
+ , q{quote_identifier( "link", "schema", "table" )}
+ );
+}
+
+# Test ping
+
+ok ($dbh->ping, "Ping the current connection ..." );
+
+# Test Get Info.
+
+# SQL_KEYWORDS
+# SQL_CATALOG_TERM
+# SQL_DATA_SOURCE_NAME
+# SQL_DBMS_NAME
+# SQL_DBMS_VERSION
+# SQL_DRIVER_NAME
+# SQL_DRIVER_VER
+# SQL_PROCEDURE_TERM
+# SQL_SCHEMA_TERM
+# SQL_TABLE_TERM
+# SQL_USER_NAME
+
+SKIP: {
+ skip("get_info() not yet implemented", 5);
+ foreach my $info (sort keys %$get_info) {
+ my $type = $dbh->get_info($get_info->{$info});
+ ok( defined $type, "get_info($info) ($get_info->{$info}) " .
+ ($type || '') );
+ }
+}
+
+# Test Table Info
+$sth = $dbh->table_info( undef, undef, undef );
+ok( defined $sth, "table_info(undef, undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->table_info( undef, undef, undef, "VIEW" );
+ok( defined $sth, "table_info(undef, undef, undef, \"VIEW\") tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+# Test Table Info Rule 19a
+$sth = $dbh->table_info( '%', '', '');
+ok( defined $sth, "table_info('%', '', '',) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+# Test Table Info Rule 19b
+$sth = $dbh->table_info( '', '%', '');
+ok( defined $sth, "table_info('', '%', '',) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+# Test Table Info Rule 19c
+$sth = $dbh->table_info( '', '', '', '%');
+ok( defined $sth, "table_info('', '', '', '%',) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+# Test to see if this database contains any of the defined table types.
+$sth = $dbh->table_info( '', '', '', '%');
+ok( defined $sth, "table_info('', '', '', '%',) tested" );
+if ($sth) {
+ my $ref = $sth->fetchall_hashref( 'TABLE_TYPE' );
+ foreach my $type ( sort keys %$ref ) {
+ my $tsth = $dbh->table_info( undef, undef, undef, $type );
+ ok( defined $tsth, "table_info(undef, undef, undef, $type) tested" );
+ DBI::dump_results($tsth) if defined $tsth;
+ $tsth->finish;
+ }
+ $sth->finish;
+}
+$sth = undef;
+
+# Test Column Info
+$sth = $dbh->column_info( undef, undef, undef, undef );
+ok( defined $sth, "column_info(undef, undef, undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser'", undef, undef );
+ok( defined $sth, "column_info(undef, 'auser', undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'ause%'", undef, undef );
+ok( defined $sth, "column_info(undef, 'ause%', undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser','replicator'", undef, undef );
+ok( defined $sth, "column_info(undef, 'auser','replicator', undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser','repl%'", undef, undef );
+ok( defined $sth, "column_info(undef, 'auser','repl%', undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'fred','repl%'", undef, undef );
+ok( defined $sth, "column_info(undef, 'fred','repl%', undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'fred','jim'", undef, undef );
+ok( defined $sth, "column_info(undef, 'fred','jim', undef, undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", undef );
+ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser'", "'pga_%'", undef );
+ok( defined $sth, "column_info(undef, 'auser', 'pga_%', undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'ause%'", "'pga_%'", undef );
+ok( defined $sth, "column_info(undef, 'ause%', 'pga_%', undef) tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", "'schemaname'" );
+ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', 'schemaname') tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser'", "'pga_schema'", "'schema%'" );
+ok( defined $sth, "column_info(undef, 'auser', 'pga_schema', 'schema%') tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'auser'", "'pga_%'", "'schema%'" );
+ok( defined $sth, "column_info(undef, 'auser', 'pga_%', 'schema%') tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+$sth = $dbh->column_info( undef, "'ause%'", "'pga_%'", "'schema%'" );
+ok( defined $sth, "column_info(undef, 'ause%', 'pga_%', 'schema%') tested" );
+DBI::dump_results($sth) if defined $sth;
+$sth = undef;
+
+# Test call to primary_key_info
+local ($dbh->{Warn}, $dbh->{PrintError});
+$dbh->{PrintError} = $dbh->{Warn} = 0;
+
+# Primary Key Info
+eval {
+ $sth = $dbh->primary_key_info();
+ die unless $sth;
+};
+ok ($@, "Call to primary_key_info with 0 arguements, error expected: $@" );
+$sth = undef;
+
+# Primary Key
+eval {
+ $sth = $dbh->primary_key();
+ die unless $sth;
+};
+ok ($@, "Call to primary_key with 0 arguements, error expected: $@" );
+$sth = undef;
+
+$sth = $dbh->primary_key_info(undef, undef, undef );
+
+ok( defined $sth, "Statement handle defined for primary_key_info()" );
+
+if ( defined $sth ) {
+ while( my $row = $sth->fetchrow_arrayref ) {
+ local $^W = 0;
+ # print join( ", ", @$row, "\n" );
+ }
+
+ undef $sth;
+
+}
+
+$sth = $dbh->primary_key_info(undef, undef, undef );
+ok( defined $sth, "Statement handle defined for primary_key_info()" );
+
+my ( %catalogs, %schemas, %tables);
+
+my $cnt = 0;
+while( my ($catalog, $schema, $table) = $sth->fetchrow_array ) {
+ local $^W = 0;
+ $catalogs{$catalog}++ if $catalog;
+ $schemas{$schema}++ if $schema;
+ $tables{$table}++ if $table;
+ $cnt++;
+}
+ok( $cnt > 0, "At least one table has a primary key." );
+
+$sth = $dbh->primary_key_info(undef, qq{'$ENV{DBI_USER}'}, undef );
+ok(
+ defined $sth
+ , "Getting primary keys for tables owned by $ENV{DBI_USER}");
+DBI::dump_results($sth) if defined $sth;
+
+undef $sth;
+
+SKIP: {
+ # foreign_key_info
+ local ($dbh->{Warn}, $dbh->{PrintError});
+ $dbh->{PrintError} = $dbh->{Warn} = 0;
+ eval {
+ $sth = $dbh->foreign_key_info();
+ die unless $sth;
+ };
+ skip "foreign_key_info not supported by driver", 1 if $@;
+ ok( defined $sth, "Statement handle defined for foreign_key_info()" );
+ DBI::dump_results($sth) if defined $sth;
+ $sth = undef;
+}
+
+ok( $dbh->disconnect, "Disconnect from database" );
+
+exit(0);
+
--- /dev/null
+use strict;
+use DBI;
+use Test::More;
+
+if (defined $ENV{DBI_DSN}) {
+ plan tests => 3;
+} else {
+ plan skip_all => 'cannot test without DB info';
+}
+
+my $dbh = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS},
+ {RaiseError => 1, AutoCommit => 0}
+ );
+ok(defined $dbh,
+ 'connect with transaction'
+ );
+
+ok($dbh->do(q{DROP TABLE test}),
+ 'drop'
+ );
+
+ok($dbh->disconnect(),
+ 'disconnect'
+ );
--- /dev/null
+package App::Info;
+
+# $Id: Info.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+=head1 NAME
+
+App::Info - Information about software packages on a system
+
+=head1 SYNOPSIS
+
+ use App::Info::Category::FooApp;
+
+ my $app = App::Info::Category::FooApp->new;
+
+ if ($app->installed) {
+ print "App name: ", $app->name, "\n";
+ print "Version: ", $app->version, "\n";
+ print "Bin dir: ", $app->bin_dir, "\n";
+ } else {
+ print "App not installed on your system. :-(\n";
+ }
+
+=head1 DESCRIPTION
+
+App::Info is an abstract base class designed to provide a generalized
+interface for subclasses that provide metadata about software packages
+installed on a system. The idea is that these classes can be used in Perl
+application installers in order to determine whether software dependencies
+have been fulfilled, and to get necessary metadata about those software
+packages.
+
+App::Info provides an event model for handling events triggered by App::Info
+subclasses. The events are classified as "info", "error", "unknown", and
+"confirm" events, and multiple handlers may be specified to handle any or all
+of these event types. This allows App::Info clients to flexibly handle events
+in any way they deem necessary. Implementing new event handlers is
+straight-forward, and use the triggering of events by App::Info subclasses is
+likewise kept easy-to-use.
+
+A few L<sample subclasses|"SEE ALSO"> are provided with the distribution, but
+others are invited to write their own subclasses and contribute them to the
+CPAN. Contributors are welcome to extend their subclasses to provide more
+information relevant to the application for which data is to be provided (see
+L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache> for an example), but are
+encouraged to, at a minimum, implement the abstract methods defined here and
+in the category abstract base classes (e.g.,
+L<App::Info::HTTPD|App::Info::HTTPD> and L<App::Info::Lib|App::Info::Lib>).
+See L<Subclassing|"SUBCLASSING"> for more information on implementing new
+subclasses.
+
+=cut
+
+use strict;
+use Carp ();
+use App::Info::Handler;
+use App::Info::Request;
+use vars qw($VERSION);
+
+$VERSION = '0.23';
+
+##############################################################################
+##############################################################################
+# This code ref is used by the abstract methods to throw an exception when
+# they're called directly.
+my $croak = sub {
+ my ($caller, $meth) = @_;
+ $caller = ref $caller || $caller;
+ if ($caller eq __PACKAGE__) {
+ $meth = __PACKAGE__ . '::' . $meth;
+ Carp::croak(__PACKAGE__ . " is an abstract base class. Attempt to " .
+ " call non-existent method $meth");
+ } else {
+ Carp::croak("Class $caller inherited from the abstract base class " .
+ __PACKAGE__ . ", but failed to redefine the $meth() " .
+ "method. Attempt to call non-existent method " .
+ "${caller}::$meth");
+ }
+};
+
+##############################################################################
+# This code reference is used by new() and the on_* error handler methods to
+# set the error handlers.
+my $set_handlers = sub {
+ my $on_key = shift;
+ # Default is to do nothing.
+ return [] unless $on_key;
+ my $ref = ref $on_key;
+ if ($ref) {
+ $on_key = [$on_key] unless $ref eq 'ARRAY';
+ # Make sure they're all handlers.
+ foreach my $h (@$on_key) {
+ if (my $r = ref $h) {
+ Carp::croak("$r object is not an App::Info::Handler")
+ unless UNIVERSAL::isa($h, 'App::Info::Handler');
+ } else {
+ # Look up the handler.
+ $h = App::Info::Handler->new( key => $h);
+ }
+ }
+ # Return 'em!
+ return $on_key;
+ } else {
+ # Look up the handler.
+ return [ App::Info::Handler->new( key => $on_key) ];
+ }
+};
+
+##############################################################################
+##############################################################################
+
+=head1 INTERFACE
+
+This section documents the public interface of App::Info.
+
+=head2 Constructor
+
+=head3 new
+
+ my $app = App::Info::Category::FooApp->new(@params);
+
+Constructs an App::Info object and returns it. The @params arguments define
+how the App::Info object will respond to certain events, and correspond to
+their like-named methods. See the L<"Event Handler Object Methods"> section
+for more information on App::Info events and how to handle them. The
+parameters to C<new()> for the different types of App::Info events are:
+
+=over 4
+
+=item on_info
+
+=item on_error
+
+=item on_unknown
+
+=item on_confirm
+
+=back
+
+When passing event handlers to C<new()>, the list of handlers for each type
+should be an anonymous array, for example:
+
+ my $app = App::Info::Category::FooApp->new( on_info => \@handlers );
+
+=cut
+
+sub new {
+ my ($pkg, %p) = @_;
+ my $class = ref $pkg || $pkg;
+ # Fail if the method isn't overridden.
+ $croak->($pkg, 'new') if $class eq __PACKAGE__;
+
+ # Set up handlers.
+ for (qw(on_error on_unknown on_info on_confirm)) {
+ $p{$_} = $set_handlers->($p{$_});
+ }
+
+ # Do it!
+ return bless \%p, $class;
+}
+
+##############################################################################
+##############################################################################
+
+=head2 Metadata Object Methods
+
+These are abstract methods in App::Info and must be provided by its
+subclasses. They provide the essential metadata of the software package
+supported by the App::Info subclass.
+
+=head3 key_name
+
+ my $key_name = $app->key_name;
+
+Returns a string that uniquely identifies the software for which the App::Info
+subclass provides data. This value should be unique across all App::Info
+classes. Typically, it's simply the name of the software.
+
+=cut
+
+sub key_name { $croak->(shift, 'key_name') }
+
+=head3 installed
+
+ if ($app->installed) {
+ print "App is installed.\n"
+ } else {
+ print "App is not installed.\n"
+ }
+
+Returns a true value if the application is installed, and a false value if it
+is not.
+
+=cut
+
+sub installed { $croak->(shift, 'installed') }
+
+##############################################################################
+
+=head3 name
+
+ my $name = $app->name;
+
+Returns the name of the application.
+
+=cut
+
+sub name { $croak->(shift, 'name') }
+
+##############################################################################
+
+=head3 version
+
+ my $version = $app->version;
+
+Returns the full version number of the application.
+
+=cut
+
+##############################################################################
+
+sub version { $croak->(shift, 'version') }
+
+=head3 major_version
+
+ my $major_version = $app->major_version;
+
+Returns the major version number of the application. For example, if
+C<version()> returns "7.1.2", then this method returns "7".
+
+=cut
+
+sub major_version { $croak->(shift, 'major_version') }
+
+##############################################################################
+
+=head3 minor_version
+
+ my $minor_version = $app->minor_version;
+
+Returns the minor version number of the application. For example, if
+C<version()> returns "7.1.2", then this method returns "1".
+
+=cut
+
+sub minor_version { $croak->(shift, 'minor_version') }
+
+##############################################################################
+
+=head3 patch_version
+
+ my $patch_version = $app->patch_version;
+
+Returns the patch version number of the application. For example, if
+C<version()> returns "7.1.2", then this method returns "2".
+
+=cut
+
+sub patch_version { $croak->(shift, 'patch_version') }
+
+##############################################################################
+
+=head3 bin_dir
+
+ my $bin_dir = $app->bin_dir;
+
+Returns the full path the application's bin directory, if it exists.
+
+=cut
+
+sub bin_dir { $croak->(shift, 'bin_dir') }
+
+##############################################################################
+
+=head3 inc_dir
+
+ my $inc_dir = $app->inc_dir;
+
+Returns the full path the application's include directory, if it exists.
+
+=cut
+
+sub inc_dir { $croak->(shift, 'inc_dir') }
+
+##############################################################################
+
+=head3 lib_dir
+
+ my $lib_dir = $app->lib_dir;
+
+Returns the full path the application's lib directory, if it exists.
+
+=cut
+
+sub lib_dir { $croak->(shift, 'lib_dir') }
+
+##############################################################################
+
+=head3 so_lib_dir
+
+ my $so_lib_dir = $app->so_lib_dir;
+
+Returns the full path the application's shared library directory, if it
+exists.
+
+=cut
+
+sub so_lib_dir { $croak->(shift, 'so_lib_dir') }
+
+##############################################################################
+
+=head3 home_url
+
+ my $home_url = $app->home_url;
+
+The URL for the software's home page.
+
+=cut
+
+sub home_url { $croak->(shift, 'home_url') }
+
+##############################################################################
+
+=head3 download_url
+
+ my $download_url = $app->download_url;
+
+The URL for the software's download page.
+
+=cut
+
+sub download_url { $croak->(shift, 'download_url') }
+
+##############################################################################
+##############################################################################
+
+=head2 Event Handler Object Methods
+
+These methods provide control over App::Info event handling. Events can be
+handled by one or more objects of subclasses of App::Info::Handler. The first
+to return a true value will be the last to execute. This approach allows
+handlers to be stacked, and makes it relatively easy to create new handlers.
+L<App::Info::Handler|App::Info::Handler> for information on writing event
+handlers.
+
+Each of the event handler methods takes a list of event handlers as its
+arguments. If none are passed, the existing list of handlers for the relevant
+event type will be returned. If new handlers are passed in, they will be
+returned.
+
+The event handlers may be specified as one or more objects of the
+App::Info::Handler class or subclasses, as one or more strings that tell
+App::Info construct such handlers itself, or a combination of the two. The
+strings can only be used if the relevant App::Info::Handler subclasses have
+registered strings with App::Info. For example, the App::Info::Handler::Print
+class included in the App::Info distribution registers the strings "stderr"
+and "stdout" when it starts up. These strings may then be used to tell
+App::Info to construct App::Info::Handler::Print objects that print to STDERR
+or to STDOUT, respectively. See the App::Info::Handler subclasses for what
+strings they register with App::Info.
+
+=head3 on_info
+
+ my @handlers = $app->on_info;
+ $app->on_info(@handlers);
+
+Info events are triggered when the App::Info subclass wants to send an
+informational status message. By default, these events are ignored, but a
+common need is for such messages to simply print to STDOUT. Use the
+L<App::Info::Handler::Print|App::Info::Handler::Print> class included with the
+App::Info distribution to have info messages print to STDOUT:
+
+ use App::Info::Handler::Print;
+ $app->on_info('stdout');
+ # Or:
+ my $stdout_handler = App::Info::Handler::Print->new('stdout');
+ $app->on_info($stdout_handler);
+
+=cut
+
+sub on_info {
+ my $self = shift;
+ $self->{on_info} = $set_handlers->(\@_) if @_;
+ return @{ $self->{on_info} };
+}
+
+=head3 on_error
+
+ my @handlers = $app->on_error;
+ $app->on_error(@handlers);
+
+Error events are triggered when the App::Info subclass runs into an unexpected
+but not fatal problem. (Note that fatal problems will likely throw an
+exception.) By default, these events are ignored. A common way of handling
+these events is to print them to STDERR, once again using the
+L<App::Info::Handler::Print|App::Info::Handler::Print> class included with the
+App::Info distribution:
+
+ use App::Info::Handler::Print;
+ my $app->on_error('stderr');
+ # Or:
+ my $stderr_handler = App::Info::Handler::Print->new('stderr');
+ $app->on_error($stderr_handler);
+
+Another approach might be to turn such events into fatal exceptions. Use the
+included L<App::Info::Handler::Carp|App::Info::Handler::Carp> class for this
+purpose:
+
+ use App::Info::Handler::Carp;
+ my $app->on_error('croak');
+ # Or:
+ my $croaker = App::Info::Handler::Carp->new('croak');
+ $app->on_error($croaker);
+
+=cut
+
+sub on_error {
+ my $self = shift;
+ $self->{on_error} = $set_handlers->(\@_) if @_;
+ return @{ $self->{on_error} };
+}
+
+=head3 on_unknown
+
+ my @handlers = $app->on_unknown;
+ $app->on_uknown(@handlers);
+
+Unknown events are trigged when the App::Info subclass cannot find the value
+to be returned by a method call. By default, these events are ignored. A
+common way of handling them is to have the application prompt the user for the
+relevant data. The App::Info::Handler::Prompt class included with the
+App::Info distribution can do just that:
+
+ use App::Info::Handler::Prompt;
+ my $app->on_unknown('prompt');
+ # Or:
+ my $prompter = App::Info::Handler::Prompt;
+ $app->on_unknown($prompter);
+
+See L<App::Info::Handler::Prompt|App::Info::Handler::Prompt> for information
+on how it works.
+
+=cut
+
+sub on_unknown {
+ my $self = shift;
+ $self->{on_unknown} = $set_handlers->(\@_) if @_;
+ return @{ $self->{on_unknown} };
+}
+
+=head3 on_confirm
+
+ my @handlers = $app->on_confirm;
+ $app->on_confirm(@handlers);
+
+Confirm events are triggered when the App::Info subclass has found an
+important piece of information (such as the location of the executable it'll
+use to collect information for the rest of its methods) and wants to confirm
+that the information is correct. These events will most often be triggered
+during the App::Info subclass object construction. Here, too, the
+App::Info::Handler::Prompt class included with the App::Info distribution can
+help out:
+
+ use App::Info::Handler::Prompt;
+ my $app->on_confirm('prompt');
+ # Or:
+ my $prompter = App::Info::Handler::Prompt;
+ $app->on_confirm($prompter);
+
+=cut
+
+sub on_confirm {
+ my $self = shift;
+ $self->{on_confirm} = $set_handlers->(\@_) if @_;
+ return @{ $self->{on_confirm} };
+}
+
+##############################################################################
+##############################################################################
+
+=head1 SUBCLASSING
+
+As an abstract base class, App::Info is not intended to be used directly.
+Instead, you'll use concrete subclasses that implement the interface it
+defines. These subclasses each provide the metadata necessary for a given
+software package, via the interface outlined above (plus any additional
+methods the class author deems sensible for a given application).
+
+This section describes the facilities App::Info provides for subclassing. The
+goal of the App::Info design has been to make subclassing straight-forward, so
+that developers can focus on gathering the data they need for their
+application and minimize the work necessary to handle unknown values or to
+confirm values. As a result, there are essentially three concepts that
+developers need to understand when subclassing App::Info: organization,
+utility methods, and events.
+
+=head2 Organization
+
+The organizational idea behind App::Info is to name subclasses by broad
+software categories. This approach allows the categories themselves to
+function as abstract base classes that extend App::Info, so that they can
+specify more methods for all of their base classes to implement. For example,
+App::Info::HTTPD has specified the C<httpd_root()> abstract method that its
+subclasses must implement. So as you get ready to implement your own subclass,
+think about what category of software you're gathering information about.
+New categories can be added as necessary.
+
+=head2 Utility Methods
+
+Once you've decided on the proper category, you can start implementing your
+App::Info concrete subclass. As you do so, take advantage of App::Info::Util,
+wherein I've tried to encapsulate common functionality to make subclassing
+easier. I found that most of what I was doing repetitively was looking for
+files and directories, and searching through files. Thus, App::Info::Util
+subclasses L<File::Spec|File::Spec> in order to offer easy access to
+commonly-used methods from that class, e.g., C<path()>. Plus, it has several
+of its own methods to assist you in finding files and directories in lists of
+files and directories, as well as methods for searching through files and
+returning the values found in those files. See
+L<App::Info::Util|App::Info::Util> for more information, and the App::Info
+subclasses in this distribution for usage examples.
+
+I recommend the use of a package-scoped lexical App::Info::Util object. That
+way it's nice and handy when you need to carry out common tasks. If you find
+you're doing something over and over that's not already addressed by an
+App::Info::Util method, consider submitting a patch to App::Info::Util to add
+the functionality you need.
+
+=head2 Events
+
+Use the methods described below to trigger events. Events are designed to
+provide a simple way for App::Info subclass developers to send status messages
+and errors, to confirm data values, and to request a value when the class
+caonnot determine a value itself. Events may optionally be handled by module
+users who assign App::Info::Handler subclass objects to your App::Info
+subclass object using the event handling methods described in the L<"Event
+Handler Object Methods"> section.
+
+=cut
+
+##############################################################################
+# This code reference is used by the event methods to manage the stack of
+# event handlers that may be available to handle each of the events.
+my $handler = sub {
+ my ($self, $meth, $params) = @_;
+
+ # Sanity check. We really want to keep control over this.
+ Carp::croak("Cannot call protected method $meth()")
+ unless UNIVERSAL::isa($self, scalar caller(1));
+
+ # Create the request object.
+ $params->{type} ||= $meth;
+ my $req = App::Info::Request->new(%$params);
+
+ # Do the deed. The ultimate handling handler may die.
+ foreach my $eh (@{$self->{"on_$meth"}}) {
+ last if $eh->handler($req);
+ }
+
+ # Return the requst.
+ return $req;
+};
+
+##############################################################################
+
+=head3 info
+
+ $self->info(@message);
+
+Use this method to display status messages for the user. You may wish to use
+it to inform users that you're searching for a particular file, or attempting
+to parse a file or some other resource for the data you need. For example, a
+common use might be in the object constructor: generally, when an App::Info
+object is created, some important initial piece of information is being
+sought, such as an executable file. That file may be in one of many locations,
+so it makes sense to let the user know that you're looking for it:
+
+ $self->info("Searching for executable");
+
+Note that, due to the nature of App::Info event handlers, your informational
+message may be used or displayed any number of ways, or indeed not at all (as
+is the default behavior).
+
+The C<@message> will be joined into a single string and stored in the
+C<message> attribute of the App::Info::Request object passed to info event
+handlers.
+
+=cut
+
+sub info {
+ my $self = shift;
+ # Execute the handler sequence.
+ my $req = $handler->($self, 'info', { message => join '', @_ });
+}
+
+##############################################################################
+
+=head3 error
+
+ $self->error(@error);
+
+Use this method to inform the user that something unexpected has happened. An
+example might be when you invoke another program to parse its output, but it's
+output isn't what you expected:
+
+ $self->error("Unable to parse version from `/bin/myapp -c`");
+
+As with all events, keep in mind that error events may be handled in any
+number of ways, or not at all.
+
+The C<@erorr> will be joined into a single string and stored in the C<message>
+attribute of the App::Info::Request object passed to error event handlers. If
+that seems confusing, think of it as an "error message" rather than an "error
+error." :-)
+
+=cut
+
+sub error {
+ my $self = shift;
+ # Execute the handler sequence.
+ my $req = $handler->($self, 'error', { message => join '', @_ });
+}
+
+##############################################################################
+
+=head3 unknown
+
+ my $val = $self->unknown(@params);
+
+Use this method when a value is unknown. This will give the user the option --
+assuming the appropriate handler handles the event -- to provide the needed
+data. The value entered will be returned by C<unknown()>. The parameters are
+as follows:
+
+=over 4
+
+=item key
+
+The C<key> parameter uniquely identifies the data point in your class, and is
+used by App::Info to ensure that an unknown event is handled only once, no
+matter how many times the method is called. The same value will be returned by
+subsequent calls to C<unknown()> as was returned by the first call, and no
+handlers will be activated. Typical values are "version" and "lib_dir".
+
+=item prompt
+
+The C<prompt> parameter is the prompt to be displayed should an event handler
+decide to prompt for the appropriate value. Such a prompt might be something
+like "Path to your httpd executable?". If this parameter is not provided,
+App::Info will construct one for you using your class' C<key_name()> method
+and the C<key> parameter. The result would be something like "Enter a valid
+FooApp version". The C<prompt> parameter value will be stored in the
+C<message> attribute of the App::Info::Request object passed to event
+handlers.
+
+=item callback
+
+Assuming a handler has collected a value for your unknown data point, it might
+make sense to validate the value. For example, if you prompt the user for a
+directory location, and the user enters one, it makes sense to ensure that the
+directory actually exists. The C<callback> parameter allows you to do this. It
+is a code reference that takes the new value or values as its arguments, and
+returns true if the value is valid, and false if it is not. For the sake of
+convenience, the first argument to the callback code reference is also stored
+in C<$_> .This makes it easy to validate using functions or operators that,
+er, operate on C<$_> by default, but still allows you to get more information
+from C<@_> if necessary. For the directory example, a good callback might be
+C<sub { -d }>. The C<callback> parameter code reference will be stored in the
+C<callback> attribute of the App::Info::Request object passed to event
+handlers.
+
+=item error
+
+The error parameter is the error message to display in the event that the
+C<callback> code reference returns false. This message may then be used by the
+event handler to let the user know what went wrong with the data she entered.
+For example, if the unknown value was a directory, and the user entered a
+value that the C<callback> identified as invalid, a message to display might
+be something like "Invalid directory path". Note that if the C<error>
+parameter is not provided, App::Info will supply the generic error message
+"Invalid value". This value will be stored in the C<error> attribute of the
+App::Info::Request object passed to event handlers.
+
+=back
+
+This may be the event method you use most, as it should be called in every
+metadata method if you cannot provide the data needed by that method. It will
+typically be the last part of the method. Here's an example demonstrating each
+of the above arguments:
+
+ my $dir = $self->unknown( key => 'lib_dir',
+ prompt => "Enter lib directory path",
+ callback => sub { -d },
+ error => "Not a directory");
+
+=cut
+
+sub unknown {
+ my ($self, %params) = @_;
+ my $key = delete $params{key}
+ or Carp::croak("No key parameter passed to unknown()");
+ # Just return the value if we've already handled this value. Ideally this
+ # shouldn't happen.
+ return $self->{__unknown__}{$key} if exists $self->{__unknown__}{$key};
+
+ # Create a prompt and error message, if necessary.
+ $params{message} = delete $params{prompt} ||
+ "Enter a valid " . $self->key_name . " $key";
+ $params{error} ||= 'Invalid value';
+
+ # Execute the handler sequence.
+ my $req = $handler->($self, "unknown", \%params);
+
+ # Mark that we've provided this value and then return it.
+ $self->{__unknown__}{$key} = $req->value;
+ return $self->{__unknown__}{$key};
+}
+
+##############################################################################
+
+=head3 confirm
+
+ my $val = $self->confirm(@params);
+
+This method is very similar to C<unknown()>, but serves a different purpose.
+Use this method for significant data points where you've found an appropriate
+value, but want to ensure it's really the correct value. A "significant data
+point" is usually a value essential for your class to collect metadata values.
+For example, you might need to locate an executable that you can then call to
+collect other data. In general, this will only happen once for an object --
+during object construction -- but there may be cases in which it is needed
+more than that. But hopefully, once you've confirmed in the constructor that
+you've found what you need, you can use that information to collect the data
+needed by all of the metadata methods and can assume that they'll be right
+because that first, significant data point has been confirmed.
+
+Other than where and how often to call C<confirm()>, its use is quite similar
+to that of C<unknown()>. Its parameters are as follows:
+
+=over
+
+=item key
+
+Same as for C<unknown()>, a string that uniquely identifies the data point in
+your class, and ensures that the event is handled only once for a given key.
+The same value will be returned by subsequent calls to C<confirm()> as was
+returned by the first call for a given key.
+
+=item prompt
+
+Same as for C<unknown()>. Although C<confirm()> is called to confirm a value,
+typically the prompt should request the relevant value, just as for
+C<unknown()>. The difference is that the handler I<should> use the C<value>
+parameter as the default should the user not provide a value. The C<prompt>
+parameter will be stored in the C<message> attribute of the App::Info::Request
+object passed to event handlers.
+
+=item value
+
+The value to be confirmed. This is the value you've found, and it will be
+provided to the user as the default option when they're prompted for a new
+value. This value will be stored in the C<value> attribute of the
+App::Info::Request object passed to event handlers.
+
+=item callback
+
+Same as for C<unknown()>. Because the user can enter data to replace the
+default value provided via the C<value> parameter, you might want to validate
+it. Use this code reference to do so. The callback will be stored in the
+C<callback> attribute of the App::Info::Request object passed to event
+handlers.
+
+=item error
+
+Same as for C<unknown()>: an error message to display in the event that a
+value entered by the user isn't validated by the C<callback> code reference.
+This value will be stored in the C<error> attribute of the App::Info::Request
+object passed to event handlers.
+
+=back
+
+Here's an example usage demonstrating all of the above arguments:
+
+ my $exe = $self->confirm( key => 'shell',
+ prompt => 'Path to your shell?',
+ value => '/bin/sh',
+ callback => sub { -x },
+ error => 'Not an executable');
+
+
+=cut
+
+sub confirm {
+ my ($self, %params) = @_;
+ my $key = delete $params{key}
+ or Carp::croak("No key parameter passed to confirm()");
+ return $self->{__confirm__}{$key} if exists $self->{__confirm__}{$key};
+
+ # Create a prompt and error message, if necessary.
+ $params{message} = delete $params{prompt} ||
+ "Enter a valid " . $self->key_name . " $key";
+ $params{error} ||= 'Invalid value';
+
+ # Execute the handler sequence.
+ my $req = $handler->($self, "confirm", \%params);
+
+ # Mark that we've confirmed this value.
+ $self->{__confirm__}{$key} = $req->value;
+
+ return $self->{__confirm__}{$key}
+}
+
+1;
+__END__
+
+=head2 Event Examples
+
+Below I provide some examples demonstrating the use of the event methods.
+These are meant to emphasize the contexts in which it's appropriate to use
+them.
+
+Let's start with the simplest, first. Let's say that to find the version
+number for an application, you need to search a file for the relevant data.
+Your App::Info concrete subclass might have a private method that handles this
+work, and this method is the appropriate place to use the C<info()> and, if
+necessary, C<error()> methods.
+
+ sub _find_version {
+ my $self = shift;
+
+ # Try to find the revelant file. We cover this method below.
+ # Just return if we cant' find it.
+ my $file = $self->_find_file('version.conf') or return;
+
+ # Send a status message.
+ $self->info("Searching '$file' file for version");
+
+ # Search the file. $util is an App::Info::Util object.
+ my $ver = $util->search_file($file, qr/^Version\s+(.*)$/);
+
+ # Trigger an error message, if necessary. We really think we'll have the
+ # value, but we have to cover our butts in the unlikely event that we're
+ # wrong.
+ $self->error("Unable to find version in file '$file'") unless $ver;
+
+ # Return the version number.
+ return $ver;
+ }
+
+Here we've used the C<info()> method to display a status message to let the
+user know what we're doing. Then we used the C<error()> method when something
+unexpected happened, which in this case was that we weren't able to find the
+version number in the file.
+
+Note the C<_find_file()> method we've thrown in. This might be a method that
+we call whenever we need to find a file that might be in one of a list of
+directories. This method, too, will be an appropriate place for an C<info()>
+method call. But rather than call the C<error()> method when the file can't be
+found, you might want to give an event handler a chance to supply that value
+for you. Use the C<unknown()> method for a case such as this:
+
+ sub _find_file {
+ my ($self, $file) = @_;
+
+ # Send a status message.
+ $self->info("Searching for '$file' file");
+
+ # Look for the file. See App::Info:Utility for its interface.
+ my @paths = qw(/usr/conf /etc/conf /foo/conf);
+ my $found = $util->first_cat_path($file, @paths);
+
+ # If we didn't find it, trigger an unknown event to
+ # give a handler a chance to get the value.
+ $found ||= $self->unknown( key => "file_$file",
+ prompt => "Location of '$file' file?",
+ callback => sub { -f },
+ error => "Not a file");
+
+ # Now return the file name, regardless of whether we found it or not.
+ return $found;
+ }
+
+Note how in this method, we've tried to locate the file ourselves, but if we
+can't find it, we trigger an unknown event. This allows clients of our
+App::Info subclass to try to establish the value themselves by having an
+App::Info::Handler subclass handle the event. If a value is found by an
+App::Info::Handler subclass, it will be returned by C<unknown()> and we can
+continue. But we can't assume that the unknown event will even be handled, and
+thus must expect that an unknown value may remain unknown. This is why the
+C<_find_version()> method above simply returns if C<_find_file()> doesn't
+return a file name; there's no point in searching through a file that doesn't
+exist.
+
+Attentive readers may be left to wonder how to decide when to use C<error()>
+and when to use C<unknown()>. To a large extent, this decision must be based
+on one's own understanding of what's most appropriate. Nevertheless, I offer
+the following simple guidelines: Use C<error()> when you expect something to
+work and then it just doesn't (as when a file exists and should contain the
+information you seek, but then doesn't). Use C<unknown()> when you're less
+sure of your processes for finding the value, and also for any of the values
+that should be returned by any of the L<metadata object methods|"Metadata
+Object Methods">. And of course, C<error()> would be more appropriate when you
+encounter an unexpected condition and don't think that it could be handled in
+any other way.
+
+Now, more than likely, a method such C<_find_version()> would be called by the
+C<version()> method, which is a metadata method mandated by the App::Info
+abstract base class. This is an appropriate place to handle an unknown version
+value. Indeed, every one of your metadata methods should make use of the
+C<unknown()> method. The C<version()> method then should look something like
+this:
+
+ sub version {
+ my $self = shift;
+
+ unless (exists $self->{version}) {
+ # Try to find the version number.
+ $self->{version} = $self->_find_version ||
+ $self->unknown( key => 'version',
+ prompt => "Enter the version number");
+ }
+
+ # Now return the version number.
+ return $self->{version};
+ }
+
+Note how this method only tries to find the version number once. Any
+subsequent calls to C<version()> will return the same value that was returned
+the first time it was called. Of course, thanks to the C<key> parameter in the
+call to C<unknown()>, we could have have tried to enumerate the version number
+every time, as C<unknown()> will return the same value every time it is called
+(as, indeed, should C<_find_version()>. But by checking for the C<version> key
+in C<$self> ourselves, we save some of the overhead.
+
+But as I said before, every metadata method should make use of the
+C<unknown()> method. Thus, the C<major()> method might looks something like
+this:
+
+ sub major {
+ my $self = shift;
+
+ unless (exists $self->{major}) {
+ # Try to get the major version from the full version number.
+ ($self->{major}) = $self->version =~ /^(\d+)\./;
+ # Handle an unknown value.
+ $self->{major} = $self->unknown( key => 'major',
+ prompt => "Enter major version",
+ callback => sub { /^\d+$/ },
+ error => "Not a number")
+ unless defined $self->{major};
+ }
+
+ return $self->{version};
+ }
+
+Finally, the C<confirm()> method should be used to verify core pieces of data
+that significant numbers of other methods rely on. Typically such data are
+executables or configuration files from which will be drawn other metadata.
+Most often, such major data points will be sought in the object constructor.
+Here's an example:
+
+ sub new {
+ # Construct the object so that handlers will work properly.
+ my $self = shift->SUPER::new(@_);
+
+ # Try to find the executable.
+ $self->info("Searching for executable");
+ if (my $exe = $util->first_exe('/bin/myapp', '/usr/bin/myapp')) {
+ # Confirm it.
+ $self->{exe} =
+ $self->confirm( key => 'binary',
+ prompt => 'Path to your executable?',
+ value => $exe,
+ callback => sub { -x },
+ error => 'Not an executable');
+ } else {
+ # Handle an unknown value.
+ $self->{exe} =
+ $self->unknown( key => 'binary',
+ prompt => 'Path to your executable?',
+ callback => sub { -x },
+ error => 'Not an executable');
+ }
+
+ # We're done.
+ return $self;
+ }
+
+By now, most of what's going on here should be quite familiar. The use of the
+C<confirm()> method is quite similar to that of C<unknown()>. Really the only
+difference is that the value is known, but we need verification or a new value
+supplied if the value we found isn't correct. Such may be the case when
+multiple copies of the executable have been installed on the system, we found
+F</bin/myapp>, but the user may really be interested in F</usr/bin/myapp>.
+Thus the C<confirm()> event gives the user the chance to change the value if
+the confirm event is handled.
+
+The final thing to note about this constructor is the first line:
+
+ my $self = shift->SUPER::new(@_);
+
+The first thing an App::Info subclass should do is execute this line to allow
+the super class to construct the object first. Doing so allows any event
+handling arguments to set up the event handlers, so that when we call
+C<confirm()> or C<unknown()> the event will be handled as the client expects.
+
+If we needed our subclass constructor to take its own parameter argumente, the
+approach is to specify the same C<key => $arg> syntax as is used by
+App::Info's C<new()> method. Say we wanted to allow clients of our App::Info
+subclass to pass in a list of alternate executable locations for us to search.
+Such an argument would most make sense as an array reference. So we specify
+that the key be C<alt_paths> and allow the user to construct an object like
+this:
+
+ my $app = App::Info::Category::FooApp->new( alt_paths => \@paths );
+
+This approach allows the super class constructor arguments to pass unmolested
+(as long as we use unique keys!):
+
+ my $app = App::Info::Category::FooApp->new( on_error => \@handlers,
+ alt_paths => \@paths );
+
+Then, to retrieve these paths inside our C<new()> constructor, all we need do
+is access them directly from the object:
+
+ my $self = shift->SUPER::new(@_);
+ my $alt_paths = $self->{alt_paths};
+
+=head2 Subclassing Guidelines
+
+To summarize, here are some guidelines for subclassing App::Info.
+
+=over 4
+
+=item *
+
+Always subclass an App::Info category subclass. This will help to keep the
+App::Info namespace well-organized. New categories can be added as needed.
+
+=item *
+
+When you create the C<new()> constructor, always call C<SUPER::new(@_)>. This
+ensures that the event handling methods methods defined by the App::Info base
+classes (e.g., C<error()>) will work properly.
+
+=item *
+
+Use a package-scoped lexical App::Info::Util object to carry out common tasks.
+If you find you're doing something over and over that's not already addressed
+by an App::Info::Util method, and you think that others might find your
+solution useful, consider submitting a patch to App::Info::Util to add the
+functionality you need. See L<App::Info::Util|App::Info::Util> for complete
+documentation of its interface.
+
+=item *
+
+Use the C<info()> event triggering method to send messages to users of your
+subclass.
+
+=item *
+
+Use the C<error()> event triggering method to alert users of unexpected
+conditions. Fatal errors should still be fatal; use C<Carp::croak()> to throw
+exceptions for fatal errors.
+
+=item *
+
+Use the C<unknown()> event triggering method when a metadata or other
+important value is unknown and you want to give any event handlers the chance
+to provide the data.
+
+=item *
+
+Use the C<confirm()> event triggering method when a core piece of data is
+known (such as the location of an executable in the C<new()> constructor) and
+you need to make sure that you have the I<correct> information.
+
+=item *
+
+Be sure to implement B<all> of the abstract methods defined by App::Info and
+by your category abstract base class -- even if they don't do anything. Doing
+so ensures that all App::Info subclasses share a common interface, and can, if
+necessary, be used without regard to subclass. Any method not implemented but
+called on an object will generate a fatal exception.
+
+=back
+
+Otherwise, have fun! There are a lot of software packages for which relevant
+information might be collected and aggregated into an App::Info concrete
+subclass (witness all of the Automake macros in the world!), and folks who are
+knowledgeable about particular software packages or categories of software are
+warmly invited to contribute. As more subclasses are implemented, it will make
+sense, I think, to create separate distributions based on category -- or even,
+when necessary, on a single software package. Broader categories can then be
+aggregated in Bundle distributions.
+
+But I get ahead of myself...
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
+
+=head1 SEE ALSO
+
+The following classes define a few software package categories in which
+App::Info subclasses can be placed. Check them out for ideas on how to
+create new category subclasses.
+
+=over 4
+
+=item L<App::Info::HTTP|App::Info::HTTPD>
+
+=item L<App::Info::RDBMS|App::Info::RDBMS>
+
+=item L<App::Info::Lib|App::Info::Lib>
+
+=back
+
+The following classes implement the App::Info interface for various software
+packages. Check them out for examples of how to implement new App::Info
+concrete subclasses.
+
+=over
+
+=item L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache>
+
+=item L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
+
+=item L<App::Info::Lib::Expat|App::Info::Lib::Expat>
+
+=item L<App::Info::Lib::Iconv|App::Info::Lib::Iconv>
+
+=back
+
+L<App::Info::Util|App::Info::Util> provides utility methods for App::Info
+subclasses.
+
+L<App::Info::Handler|App::Info::Handler> defines an interface for event
+handlers to subclass. Consult its documentation for information on creating
+custom event handlers.
+
+The following classes implement the App::Info::Handler interface to offer some
+simple event handling. Check them out for examples of how to implement new
+App::Info::Handler subclasses.
+
+=over 4
+
+=item L<App::Info::Handler::Print|App::Info::Handler::Print>
+
+=item L<App::Info::Handler::Carp|App::Info::Handler::Carp>
+
+=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
--- /dev/null
+package App::Info::Handler;
+
+# $Id: Handler.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+=head1 NAME
+
+App::Info::Handler - App::Info event handler base class
+
+=head1 SYNOPSIS
+
+ use App::Info::Category::FooApp;
+ use App::Info::Handler;
+
+ my $app = App::Info::Category::FooApp->new( on_info => ['default'] );
+
+=head1 DESCRIPTION
+
+This class defines the interface for subclasses that wish to handle events
+triggered by App::Info concrete subclasses. The different types of events
+triggered by App::Info can all be handled by App::Info::Handler (indeed, by
+default they're all handled by a single App::Info::Handler object), and
+App::Info::Handler subclasses may be designed to handle whatever events they
+wish.
+
+If you're interested in I<using> an App::Info event handler, this is probably
+not the class you should look at, since all it does is define a simple handler
+that does nothing with an event. Look to the L<App::Info::Handler
+subclasses|"SEE ALSO"> included in this distribution to do more interesting
+things with App::Info events.
+
+If, on the other hand, you're interested in implementing your own event
+handlers, read on!
+
+=cut
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.22';
+
+my %handlers;
+
+=head1 INTERFACE
+
+This section documents the public interface of App::Info::Handler.
+
+=head2 Class Method
+
+=head3 register_handler
+
+ App::Info::Handler->register_handler( $key => $code_ref );
+
+This class method may be used by App::Info::Handler subclasses to register
+themselves with App::Info::Handler. Multiple registrations are supported. The
+idea is that a subclass can define different functionality by specifying
+different strings that represent different modes of constructing an
+App::Info::Handler subclass object. The keys are case-sensitve, and should be
+unique across App::Info::Handler subclasses so that many subclasses can be
+loaded and used separately. If the C<$key> is already registered,
+C<register_handler()> will throw an exception. The values are code references
+that, when executed, return the appropriate App::Info::Handler subclass
+object.
+
+=cut
+
+sub register_handler {
+ my ($pkg, $key, $code) = @_;
+ Carp::croak("Handler '$key' already exists")
+ if $handlers{$key};
+ $handlers{$key} = $code;
+}
+
+# Register ourself.
+__PACKAGE__->register_handler('default', sub { __PACKAGE__->new } );
+
+##############################################################################
+
+=head2 Constructor
+
+=head3 new
+
+ my $handler = App::Info::Handler->new;
+ $handler = App::Info::Handler->new( key => $key);
+
+Constructs an App::Info::Handler object and returns it. If the key parameter
+is provided and has been registered by an App::Info::Handler subclass via the
+C<register_handler()> class method, then the relevant code reference will be
+executed and the resulting App::Info::Handler subclass object returned. This
+approach provides a handy shortcut for having C<new()> behave as an abstract
+factory method, returning an object of the subclass appropriate to the key
+parameter.
+
+=cut
+
+sub new {
+ my ($pkg, %p) = @_;
+ my $class = ref $pkg || $pkg;
+ $p{key} ||= 'default';
+ if ($class eq __PACKAGE__ && $p{key} ne 'default') {
+ # We were called directly! Handle it.
+ Carp::croak("No such handler '$p{key}'") unless $handlers{$p{key}};
+ return $handlers{$p{key}}->();
+ } else {
+ # A subclass called us -- just instantiate and return.
+ return bless \%p, $class;
+ }
+}
+
+=head2 Instance Method
+
+=head3 handler
+
+ $handler->handler($req);
+
+App::Info::Handler defines a single instance method that must be defined by
+its subclasses, C<handler()>. This is the method that will be executed by an
+event triggered by an App::Info concrete subclass. It takes as its single
+argument an App::Info::Request object, and returns a true value if it has
+handled the event request. Returning a false value declines the request, and
+App::Info will then move on to the next handler in the chain.
+
+The C<handler()> method implemented in App::Info::Handler itself does nothing
+more than return a true value. It thus acts as a very simple default event
+handler. See the App::Info::Handler subclasses for more interesting handling
+of events, or create your own!
+
+=cut
+
+sub handler { 1 }
+
+1;
+__END__
+
+=head1 SUBCLASSING
+
+I hatched the idea of the App::Info event model with its subclassable handlers
+as a way of separating the aggregation of application metadata from writing a
+user interface for handling certain conditions. I felt it a better idea to
+allow people to create their own user interfaces, and instead to provide only
+a few examples. The App::Info::Handler class defines the API interface for
+handling these conditions, which App::Info refers to as "events".
+
+There are various types of events defined by App::Info ("info", "error",
+"unknown", and "confirm"), but the App::Info::Handler interface is designed to
+be flexible enough to handle any and all of them. If you're interested in
+creating your own App::Info event handler, this is the place to learn how.
+
+=head2 The Interface
+
+To create an App::Info event handler, all one need do is subclass
+App::Info::Handler and then implement the C<new()> constructor and the
+C<handler()> method. The C<new()> constructor can do anything you like, and
+take any arguments you like. However, I do recommend that the first thing
+you do in your implementation is to call the super constructor:
+
+ sub new {
+ my $pkg = shift;
+ my $self = $pkg->SUPER::new(@_);
+ # ... other stuff.
+ return $self;
+ }
+
+Although the default C<new()> constructor currently doesn't do much, that may
+change in the future, so this call will keep you covered. What it does do is
+take the parameterized arguments and assign them to the App::Info::Handler
+object. Thus if you've specified a "mode" argument, where clients can
+construct objects of you class like this:
+
+ my $handler = FooHandler->new( mode => 'foo' );
+
+You can access the mode parameter directly from the object, like so:
+
+ sub new {
+ my $pkg = shift;
+ my $self = $pkg->SUPER::new(@_);
+ if ($self->{mode} eq 'foo') {
+ # ...
+ }
+ return $self;
+ }
+
+Just be sure not to use a parameter key name required by App::Info::Handler
+itself. At the moment, the only parameter accepted by App::Info::Handler is
+"key", so in general you'll be pretty safe.
+
+Next, I recommend that you take advantage of the C<register_handler()> method
+to create some shortcuts for creating handlers of your class. For example, say
+we're creating a handler subclass FooHandler. It has two modes, a default
+"foo" mode and an advanced "bar" mode. To allow both to be constructed by
+stringified shortcuts, the FooHandler class implementation might start like
+this:
+
+ package FooHandler;
+
+ use strict;
+ use App::Info::Handler;
+ use vars qw(@ISA);
+ @ISA = qw(App::Info::Handler);
+
+ foreach my $c (qw(foo bar)) {
+ App::Info::Handler->register_handler
+ ( $c => sub { __PACKAGE__->new( mode => $c) } );
+ }
+
+The strings "foo" and "bar" can then be used by clients as shortcuts to have
+App::Info objects automatically create and use handlers for certain events.
+For example, if a client wanted to use a "bar" event handler for its info
+events, it might do this:
+
+ use App::Info::Category::FooApp;
+ use FooHandler;
+
+ my $app = App::Info::Category::FooApp->new(on_info => ['bar']);
+
+Take a look at App::Info::Handler::Print and App::Info::Handler::Carp to see
+concrete examples of C<register_handler()> usage.
+
+The final step in creating a new App::Info event handler is to implement the
+C<handler()> method itself. This method takes a single argument, an
+App::Info::Request object, and is expected to return true if it handled the
+request, and false if it did not. The App::Info::Request object contains all
+the metadata relevant to a request, including the type of event that triggered
+it; see L<App::Info::Request|App::Info::Request> for its documentation.
+
+Use the App::Info::Request object however you like to handle the request
+however you like. You are, however, expected to abide by a a few guidelines:
+
+=over 4
+
+=item *
+
+For error and info events, you are expected (but not required) to somehow
+display the info or error message for the user. How your handler chooses to do
+so is up to you and the handler.
+
+=item *
+
+For unknown and confirm events, you are expected to prompt the user for a
+value. If it's a confirm event, offer the known value (found in
+C<$req-E<gt>value>) as a default.
+
+=item *
+
+For unknown and confirm events, you are expected to call C<$req-E<gt>callback>
+and pass in the new value. If C<$req-E<gt>callback> returns a false value, you
+are expected to display the error message in C<$req-E<gt>error> and prompt the
+user again. Note that C<$req-E<gt>value> calls C<$req-E<gt>callback>
+internally, and thus assigns the value and returns true if
+C<$req-E<gt>callback> returns true, and does not assign the value and returns
+false if C<$req-E<gt>callback> returns false.
+
+=item *
+
+For unknown and confirm events, if you've collected a new value and
+C<$req-E<gt>callback> returns true for that value, you are expected to assign
+the value by passing it to C<$req-E<gt>value>. This allows App::Info to give
+the value back to the calling App::Info concrete subclass.
+
+=back
+
+Probably the easiest way to get started creating new App::Info event handlers
+is to check out the simple handlers provided with the distribution and follow
+their logical examples. Consult the App::Info documentation of the L<event
+methods|App::Info/"Events"> for details on how App::Info constructs the
+App::Info::Request object for each event type.
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> thoroughly documents the client interface for setting
+event handlers, as well as the event triggering interface for App::Info
+concrete subclasses.
+
+L<App::Info::Request|App::Info::Request> documents the interface for the
+request objects passed to App::Info::Handler C<handler()> methods.
+
+The following App::Info::Handler subclasses offer examples for event handler
+authors, and, of course, provide actual event handling functionality for
+App::Info clients.
+
+=over 4
+
+=item L<App::Info::Handler::Carp|App::Info::Handler::Carp>
+
+=item L<App::Info::Handler::Print|App::Info::Handler::Print>
+
+=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
--- /dev/null
+package App::Info::Handler::Prompt;
+
+# $Id: Prompt.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $
+
+=head1 NAME
+
+App::Info::Handler::Prompt - Prompting App::Info event handler
+
+=head1 SYNOPSIS
+
+ use App::Info::Category::FooApp;
+ use App::Info::Handler::Print;
+
+ my $prompter = App::Info::Handler::Print->new;
+ my $app = App::Info::Category::FooApp->new( on_unknown => $prompter );
+
+ # Or...
+ my $app = App::Info::Category::FooApp->new( on_confirm => 'prompt' );
+
+=head1 DESCRIPTION
+
+App::Info::Handler::Prompt objects handle App::Info events by printing their
+messages to C<STDOUT> and then accepting a new value from C<STDIN>. The new
+value is validated by any callback supplied by the App::Info concrete subclass
+that triggered the event. If the value is valid, App::Info::Handler::Prompt
+assigns the new value to the event request. If it isn't it prints the error
+message associated with the event request, and then prompts for the data
+again.
+
+Although designed with unknown and confirm events in mind,
+App::Info::Handler::Prompt handles info and error events as well. It will
+simply print info event messages to C<STDOUT> and print error event messages
+to C<STDERR>. For more interesting info and error event handling, see
+L<App::Info::Handler::Print|App::Info::Handler::Print> and
+L<App::Info::Handler::Carp|App::Info::Handler::Carp>.
+
+Upon loading, App::Info::Handler::Print registers itself with
+App::Info::Handler, setting up a single string, "prompt", that can be passed
+to an App::Info concrete subclass constructor. This string is a shortcut that
+tells App::Info how to create an App::Info::Handler::Print object for handling
+events.
+
+=cut
+
+use strict;
+use App::Info::Handler;
+use vars qw($VERSION @ISA);
+$VERSION = '0.22';
+@ISA = qw(App::Info::Handler);
+
+# Register ourselves.
+App::Info::Handler->register_handler
+ ('prompt' => sub { __PACKAGE__->new('prompt') } );
+
+=head1 INTERFACE
+
+=head2 Constructor
+
+=head3 new
+
+ my $prompter = App::Info::Handler::Prompt->new;
+
+Constructs a new App::Info::Handler::Prompt object and returns it. No special
+arguments are required.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $self = $pkg->SUPER::new(@_);
+ $self->{tty} = -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) );
+ # We're done!
+ return $self;
+}
+
+my $get_ans = sub {
+ my ($prompt, $tty, $def) = @_;
+ # Print the message.
+ local $| = 1;
+ local $\;
+ print $prompt;
+
+ # Collect the answer.
+ my $ans;
+ if ($tty) {
+ $ans = <STDIN>;
+ if (defined $ans ) {
+ chomp $ans;
+ } else { # user hit ctrl-D
+ print "\n";
+ }
+ } else {
+ print "$def\n" if defined $def;
+ }
+ return $ans;
+};
+
+sub handler {
+ my ($self, $req) = @_;
+ my $ans;
+ my $type = $req->type;
+ if ($type eq 'unknown' || $type eq 'confirm') {
+ # We'll want to prompt for a new value.
+ my $val = $req->value;
+ my ($def, $dispdef) = defined $val ? ($val, " [$val] ") : ('', ' ');
+ my $msg = $req->message or Carp::croak("No message in request");
+ $msg .= $dispdef;
+
+ # Get the answer.
+ $ans = $get_ans->($msg, $self->{tty}, $def);
+ # Just return if they entered an empty string or we couldnt' get an
+ # answer.
+ return 1 unless defined $ans && $ans ne '';
+
+ # Validate the answer.
+ my $err = $req->error;
+ while (!$req->value($ans)) {
+ print "$err: '$ans'\n";
+ $ans = $get_ans->($msg, $self->{tty}, $def);
+ return 1 unless defined $ans && $ans ne '';
+ }
+
+ } elsif ($type eq 'info') {
+ # Just print the message.
+ print STDOUT $req->message, "\n";
+ } elsif ($type eq 'error') {
+ # Just print the message.
+ print STDERR $req->message, "\n";
+ } else {
+ # This shouldn't happen.
+ Carp::croak("Invalid request type '$type'");
+ }
+
+ # Return true to indicate that we've handled the request.
+ return 1;
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> documents the event handling interface.
+
+L<App::Info::Handler::Carp|App::Info::Handler::Carp> handles events by
+passing their messages Carp module functions.
+
+L<App::Info::Handler::Print|App::Info::Handler::Print> handles events by
+printing their messages to a file handle.
+
+L<App::Info::Handler|App::Info::Handler> describes how to implement custom
+App::Info event handlers.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
--- /dev/null
+package App::Info::RDBMS;
+
+# $Id: RDBMS.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+use strict;
+use App::Info;
+use vars qw(@ISA $VERSION);
+@ISA = qw(App::Info);
+$VERSION = '0.22';
+
+1;
+__END__
+
+=head1 NAME
+
+App::Info::RDBMS - Information about databases on a system
+
+=head1 DESCRIPTION
+
+This class is an abstract base class for App::Info subclasses that provide
+information about relational databases. Its subclasses are required to
+implement its interface. See L<App::Info|App::Info> for a complete description
+and L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL> for an example
+implementation.
+
+=head1 INTERFACE
+
+Currently, App::Info::RDBMS adds no more methods than those from its parent
+class, App::Info.
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info>,
+L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
+
+
+
--- /dev/null
+package App::Info::RDBMS::PostgreSQL;
+
+# $Id: PostgreSQL.pm,v 1.1 2004-04-29 09:21:29 ivan Exp $
+
+=head1 NAME
+
+App::Info::RDBMS::PostgreSQL - Information about PostgreSQL
+
+=head1 SYNOPSIS
+
+ use App::Info::RDBMS::PostgreSQL;
+
+ my $pg = App::Info::RDBMS::PostgreSQL->new;
+
+ if ($pg->installed) {
+ print "App name: ", $pg->name, "\n";
+ print "Version: ", $pg->version, "\n";
+ print "Bin dir: ", $pg->bin_dir, "\n";
+ } else {
+ print "PostgreSQL is not installed. :-(\n";
+ }
+
+=head1 DESCRIPTION
+
+App::Info::RDBMS::PostgreSQL supplies information about the PostgreSQL
+database server installed on the local system. It implements all of the
+methods defined by App::Info::RDBMS. Methods that trigger events will trigger
+them only the first time they're called (See L<App::Info|App::Info> for
+documentation on handling events). To start over (after, say, someone has
+installed PostgreSQL) construct a new App::Info::RDBMS::PostgreSQL object to
+aggregate new metadata.
+
+Some of the methods trigger the same events. This is due to cross-calling of
+shared subroutines. However, any one event should be triggered no more than
+once. For example, although the info event "Executing `pg_config --version`"
+is documented for the methods C<name()>, C<version()>, C<major_version()>,
+C<minor_version()>, and C<patch_version()>, rest assured that it will only be
+triggered once, by whichever of those four methods is called first.
+
+=cut
+
+use strict;
+use App::Info::RDBMS;
+use App::Info::Util;
+use vars qw(@ISA $VERSION);
+@ISA = qw(App::Info::RDBMS);
+$VERSION = '0.22';
+
+my $u = App::Info::Util->new;
+
+=head1 INTERFACE
+
+=head2 Constructor
+
+=head3 new
+
+ my $pg = App::Info::RDBMS::PostgreSQL->new(@params);
+
+Returns an App::Info::RDBMS::PostgreSQL object. See L<App::Info|App::Info> for
+a complete description of argument parameters.
+
+When it called, C<new()> searches the file system for the F<pg_config>
+application. If found, F<pg_config> will be called by the object methods below
+to gather the data necessary for each. If F<pg_config> cannot be found, then
+PostgreSQL is assumed not to be installed, and each of the object methods will
+return C<undef>.
+
+App::Info::RDBMS::PostgreSQL searches for F<pg_config> along your path, as
+defined by C<File::Spec-E<gt>path>. Failing that, it searches the following
+directories:
+
+=over 4
+
+=item /usr/local/pgsql/bin
+
+=item /usr/local/postgres/bin
+
+=item /opt/pgsql/bin
+
+=item /usr/local/bin
+
+=item /usr/local/sbin
+
+=item /usr/bin
+
+=item /usr/sbin
+
+=item /bin
+
+=back
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Looking for pg_config
+
+=item confirm
+
+Path to pg_config?
+
+=item unknown
+
+Path to pg_config?
+
+=back
+
+=cut
+
+sub new {
+ # Construct the object.
+ my $self = shift->SUPER::new(@_);
+
+ # Find pg_config.
+ $self->info("Looking for pg_config");
+ my @paths = ($u->path,
+ qw(/usr/local/pgsql/bin
+ /usr/local/postgres/bin
+ /opt/pgsql/bin
+ /usr/local/bin
+ /usr/local/sbin
+ /usr/bin
+ /usr/sbin
+ /bin));
+
+ if (my $cfg = $u->first_cat_exe('pg_config', @paths)) {
+ # We found it. Confirm.
+ $self->{pg_config} = $self->confirm( key => 'pg_config',
+ prompt => 'Path to pg_config?',
+ value => $cfg,
+ callback => sub { -x },
+ error => 'Not an executable');
+ } else {
+ # Handle an unknown value.
+ $self->{pg_config} = $self->unknown( key => 'pg_config',
+ prompt => 'Path to pg_config?',
+ callback => sub { -x },
+ error => 'Not an executable');
+ }
+
+ return $self;
+}
+
+# We'll use this code reference as a common way of collecting data.
+my $get_data = sub {
+ return unless $_[0]->{pg_config};
+ $_[0]->info("Executing `$_[0]->{pg_config} $_[1]`");
+ my $info = `$_[0]->{pg_config} $_[1]`;
+ chomp $info;
+ return $info;
+};
+
+##############################################################################
+
+=head2 Class Method
+
+=head3 key_name
+
+ my $key_name = App::Info::RDBMS::PostgreSQL->key_name;
+
+Returns the unique key name that describes this class. The value returned is
+the string "PostgreSQL".
+
+=cut
+
+sub key_name { 'PostgreSQL' }
+
+##############################################################################
+
+=head2 Object Methods
+
+=head3 installed
+
+ print "PostgreSQL is ", ($pg->installed ? '' : 'not '), "installed.\n";
+
+Returns true if PostgreSQL is installed, and false if it is not.
+App::Info::RDBMS::PostgreSQL determines whether PostgreSQL is installed based
+on the presence or absence of the F<pg_config> application on the file system
+as found when C<new()> constructed the object. If PostgreSQL does not appear
+to be installed, then all of the other object methods will return empty
+values.
+
+=cut
+
+sub installed { return $_[0]->{pg_config} ? 1 : undef }
+
+##############################################################################
+
+=head3 name
+
+ my $name = $pg->name;
+
+Returns the name of the application. App::Info::RDBMS::PostgreSQL parses the
+name from the system call C<`pg_config --version`>.
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --version`
+
+=item error
+
+Failed to find PostgreSQL version with `pg_config --version`
+
+Unable to parse name from string
+
+Unable to parse version from string
+
+Failed to parse PostgreSQL version parts from string
+
+=item unknown
+
+Enter a valid PostgreSQL name
+
+=back
+
+=cut
+
+# This code reference is used by name(), version(), major_version(),
+# minor_version(), and patch_version() to aggregate the data they need.
+my $get_version = sub {
+ my $self = shift;
+ $self->{'--version'} = 1;
+ my $data = $get_data->($self, '--version');
+ unless ($data) {
+ $self->error("Failed to find PostgreSQL version with ".
+ "`$self->{pg_config} --version");
+ return;
+ }
+
+ chomp $data;
+ my ($name, $version) = split /\s+/, $data, 2;
+
+ # Check for and assign the name.
+ $name ?
+ $self->{name} = $name :
+ $self->error("Unable to parse name from string '$data'");
+
+ # Parse the version number.
+ if ($version) {
+ my ($x, $y, $z) = $version =~ /(\d+)\.(\d+).(\d+)/;
+ if (defined $x and defined $y and defined $z) {
+ @{$self}{qw(version major minor patch)} =
+ ($version, $x, $y, $z);
+ } else {
+ $self->error("Failed to parse PostgreSQL version parts from " .
+ "string '$version'");
+ }
+ } else {
+ $self->error("Unable to parse version from string '$data'");
+ }
+};
+
+sub name {
+ my $self = shift;
+ return unless $self->{pg_config};
+
+ # Load data.
+ $get_version->($self) unless $self->{'--version'};
+
+ # Handle an unknown name.
+ $self->{name} ||= $self->unknown( key => 'name' );
+
+ # Return the name.
+ return $self->{name};
+}
+
+##############################################################################
+
+=head3 version
+
+ my $version = $pg->version;
+
+Returns the PostgreSQL version number. App::Info::RDBMS::PostgreSQL parses the
+version number from the system call C<`pg_config --version`>.
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --version`
+
+=item error
+
+Failed to find PostgreSQL version with `pg_config --version`
+
+Unable to parse name from string
+
+Unable to parse version from string
+
+Failed to parse PostgreSQL version parts from string
+
+=item unknown
+
+Enter a valid PostgreSQL version number
+
+=back
+
+=cut
+
+sub version {
+ my $self = shift;
+ return unless $self->{pg_config};
+
+ # Load data.
+ $get_version->($self) unless $self->{'--version'};
+
+ # Handle an unknown value.
+ unless ($self->{version}) {
+ # Create a validation code reference.
+ my $chk_version = sub {
+ # Try to get the version number parts.
+ my ($x, $y, $z) = /^(\d+)\.(\d+).(\d+)$/;
+ # Return false if we didn't get all three.
+ return unless $x and defined $y and defined $z;
+ # Save all three parts.
+ @{$self}{qw(major minor patch)} = ($x, $y, $z);
+ # Return true.
+ return 1;
+ };
+ $self->{version} = $self->unknown( key => 'version number',
+ callback => $chk_version);
+ }
+
+ return $self->{version};
+}
+
+##############################################################################
+
+=head3 major version
+
+ my $major_version = $pg->major_version;
+
+Returns the PostgreSQL major version number. App::Info::RDBMS::PostgreSQL
+parses the major version number from the system call C<`pg_config --version`>.
+For example, C<version()> returns "7.1.2", then this method returns "7".
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --version`
+
+=item error
+
+Failed to find PostgreSQL version with `pg_config --version`
+
+Unable to parse name from string
+
+Unable to parse version from string
+
+Failed to parse PostgreSQL version parts from string
+
+=item unknown
+
+Enter a valid PostgreSQL major version number
+
+=back
+
+=cut
+
+# This code reference is used by major_version(), minor_version(), and
+# patch_version() to validate a version number entered by a user.
+my $is_int = sub { /^\d+$/ };
+
+sub major_version {
+ my $self = shift;
+ return unless $self->{pg_config};
+ # Load data.
+ $get_version->($self) unless exists $self->{'--version'};
+ # Handle an unknown value.
+ $self->{major} = $self->unknown( key => 'major version number',
+ callback => $is_int)
+ unless $self->{major};
+ return $self->{major};
+}
+
+##############################################################################
+
+=head3 minor version
+
+ my $minor_version = $pg->minor_version;
+
+Returns the PostgreSQL minor version number. App::Info::RDBMS::PostgreSQL
+parses the minor version number from the system call C<`pg_config --version`>.
+For example, if C<version()> returns "7.1.2", then this method returns "2".
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --version`
+
+=item error
+
+Failed to find PostgreSQL version with `pg_config --version`
+
+Unable to parse name from string
+
+Unable to parse version from string
+
+Failed to parse PostgreSQL version parts from string
+
+=item unknown
+
+Enter a valid PostgreSQL minor version number
+
+=back
+
+=cut
+
+sub minor_version {
+ my $self = shift;
+ return unless $self->{pg_config};
+ # Load data.
+ $get_version->($self) unless exists $self->{'--version'};
+ # Handle an unknown value.
+ $self->{minor} = $self->unknown( key => 'minor version number',
+ callback => $is_int)
+ unless defined $self->{minor};
+ return $self->{minor};
+}
+
+##############################################################################
+
+=head3 patch version
+
+ my $patch_version = $pg->patch_version;
+
+Returns the PostgreSQL patch version number. App::Info::RDBMS::PostgreSQL
+parses the patch version number from the system call C<`pg_config --version`>.
+For example, if C<version()> returns "7.1.2", then this method returns "1".
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --version`
+
+=item error
+
+Failed to find PostgreSQL version with `pg_config --version`
+
+Unable to parse name from string
+
+Unable to parse version from string
+
+Failed to parse PostgreSQL version parts from string
+
+=item unknown
+
+Enter a valid PostgreSQL minor version number
+
+=back
+
+=cut
+
+sub patch_version {
+ my $self = shift;
+ return unless $self->{pg_config};
+ # Load data.
+ $get_version->($self) unless exists $self->{'--version'};
+ # Handle an unknown value.
+ $self->{patch} = $self->unknown( key => 'patch version number',
+ callback => $is_int)
+ unless defined $self->{patch};
+ return $self->{patch};
+}
+
+##############################################################################
+
+=head3 bin_dir
+
+ my $bin_dir = $pg->bin_dir;
+
+Returns the PostgreSQL binary directory path. App::Info::RDBMS::PostgreSQL
+gathers the path from the system call C<`pg_config --bindir`>.
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --bindir`
+
+=item error
+
+Cannot find bin directory
+
+=item unknown
+
+Enter a valid PostgreSQL bin directory
+
+=back
+
+=cut
+
+# This code reference is used by bin_dir(), lib_dir(), and so_lib_dir() to
+# validate a directory entered by the user.
+my $is_dir = sub { -d };
+
+sub bin_dir {
+ my $self = shift;
+ return unless $self->{pg_config};
+ unless (exists $self->{bin_dir} ) {
+ if (my $dir = $get_data->($self, '--bindir')) {
+ $self->{bin_dir} = $dir;
+ } else {
+ # Handle an unknown value.
+ $self->error("Cannot find bin directory");
+ $self->{bin_dir} = $self->unknown( key => 'bin directory',
+ callback => $is_dir)
+ }
+ }
+
+ return $self->{bin_dir};
+}
+
+##############################################################################
+
+=head3 inc_dir
+
+ my $inc_dir = $pg->inc_dir;
+
+Returns the PostgreSQL include directory path. App::Info::RDBMS::PostgreSQL
+gathers the path from the system call C<`pg_config --includedir`>.
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --includedir`
+
+=item error
+
+Cannot find include directory
+
+=item unknown
+
+Enter a valid PostgreSQL include directory
+
+=back
+
+=cut
+
+sub inc_dir {
+ my $self = shift;
+ return unless $self->{pg_config};
+ unless (exists $self->{inc_dir} ) {
+ if (my $dir = $get_data->($self, '--includedir')) {
+ $self->{inc_dir} = $dir;
+ } else {
+ # Handle an unknown value.
+ $self->error("Cannot find include directory");
+ $self->{inc_dir} = $self->unknown( key => 'include directory',
+ callback => $is_dir)
+ }
+ }
+
+ return $self->{inc_dir};
+}
+
+##############################################################################
+
+=head3 lib_dir
+
+ my $lib_dir = $pg->lib_dir;
+
+Returns the PostgreSQL library directory path. App::Info::RDBMS::PostgreSQL
+gathers the path from the system call C<`pg_config --libdir`>.
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --libdir`
+
+=item error
+
+Cannot find library directory
+
+=item unknown
+
+Enter a valid PostgreSQL library directory
+
+=back
+
+=cut
+
+sub lib_dir {
+ my $self = shift;
+ return unless $self->{pg_config};
+ unless (exists $self->{lib_dir} ) {
+ if (my $dir = $get_data->($self, '--libdir')) {
+ $self->{lib_dir} = $dir;
+ } else {
+ # Handle an unknown value.
+ $self->error("Cannot find library directory");
+ $self->{lib_dir} = $self->unknown( key => 'library directory',
+ callback => $is_dir)
+ }
+ }
+
+ return $self->{lib_dir};
+}
+
+##############################################################################
+
+=head3 so_lib_dir
+
+ my $so_lib_dir = $pg->so_lib_dir;
+
+Returns the PostgreSQL shared object library directory path.
+App::Info::RDBMS::PostgreSQL gathers the path from the system call
+C<`pg_config --pkglibdir`>.
+
+B<Events:>
+
+=over 4
+
+=item info
+
+Executing `pg_config --pkglibdir`
+
+=item error
+
+Cannot find shared object library directory
+
+=item unknown
+
+Enter a valid PostgreSQL shared object library directory
+
+=back
+
+=cut
+
+# Location of dynamically loadable modules.
+sub so_lib_dir {
+ my $self = shift;
+ return unless $self->{pg_config};
+ unless (exists $self->{so_lib_dir} ) {
+ if (my $dir = $get_data->($self, '--pkglibdir')) {
+ $self->{so_lib_dir} = $dir;
+ } else {
+ # Handle an unknown value.
+ $self->error("Cannot find shared object library directory");
+ $self->{so_lib_dir} =
+ $self->unknown( key => 'shared object library directory',
+ callback => $is_dir)
+ }
+ }
+
+ return $self->{so_lib_dir};
+}
+
+##############################################################################
+
+=head3 home_url
+
+ my $home_url = $pg->home_url;
+
+Returns the PostgreSQL home page URL.
+
+=cut
+
+sub home_url { "http://www.postgresql.org/" }
+
+##############################################################################
+
+=head3 download_url
+
+ my $download_url = $pg->download_url;
+
+Returns the PostgreSQL download URL.
+
+=cut
+
+sub download_url { "http://www.ca.postgresql.org/sitess.html" }
+
+1;
+__END__
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">> based on code by Sam
+Tregar <L<sam@tregar.com|"sam@tregar.com">>.
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> documents the event handling interface.
+
+L<App::Info::RDBMS|App::Info::RDBMS> is the App::Info::RDBMS::PostgreSQL
+parent class.
+
+L<DBD::Pg|DBD::Pg> is the L<DBI|DBI> driver for connecting to PostgreSQL
+databases.
+
+L<http://www.postgresql.org/> is the PostgreSQL home page.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
--- /dev/null
+package App::Info::Request;
+
+# $Id: Request.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+=head1 NAME
+
+App::Info::Request - App::Info event handler request object
+
+=head1 SYNOPSIS
+
+ # In an App::Info::Handler subclass:
+ sub handler {
+ my ($self, $req) = @_;
+ print "Event Type: ", $req->type;
+ print "Message: ", $req->message;
+ print "Error: ", $req->error;
+ print "Value: ", $req->value;
+ }
+
+=head1 DESCRIPTION
+
+Objects of this class are passed to the C<handler()> method of App::Info event
+handlers. Generally, this class will be of most interest to App::Info::Handler
+subclass implementers.
+
+The L<event triggering methods|App::Info/"Events"> in App::Info each construct
+a new App::Info::Request object and initialize it with their arguments. The
+App::Info::Request object is then the sole argument passed to the C<handler()>
+method of any and all App::Info::Handler objects in the event handling chain.
+Thus, if you'd like to create your own App::Info event handler, this is the
+object you need to be familiar with. Consult the
+L<App::Info::Handler|App::Info::Handler> documentation for details on creating
+custom event handlers.
+
+Each of the App::Info event triggering methods constructs an
+App::Info::Request object with different attribute values. Be sure to consult
+the documentation for the L<event triggering methods|App::Info/"Events"> in
+App::Info, where the values assigned to the App::Info::Request object are
+documented. Then, in your event handler subclass, check the value returned by
+the C<type()> method to determine what type of event request you're handling
+to handle the request appropriately.
+
+=cut
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.23';
+
+##############################################################################
+
+=head1 INTERFACE
+
+The following sections document the App::Info::Request interface.
+
+=head2 Constructor
+
+=head3 new
+
+ my $req = App::Info::Request->new(%params);
+
+This method is used internally by App::Info to construct new
+App::Info::Request objects to pass to event handler objects. Generally, you
+won't need to use it, other than perhaps for testing custom App::Info::Handler
+classes.
+
+The parameters to C<new()> are passed as a hash of named parameters that
+correspond to their like-named methods. The supported parameters are:
+
+=over 4
+
+=item type
+
+=item message
+
+=item error
+
+=item value
+
+=item callback
+
+=back
+
+See the object methods documentation below for details on these object
+attributes.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+
+ # Make sure we've got a hash of arguments.
+ Carp::croak("Odd number of parameters in call to " . __PACKAGE__ .
+ "->new() when named parameters expected" ) if @_ % 2;
+ my %params = @_;
+
+ # Validate the callback.
+ if ($params{callback}) {
+ Carp::croak("Callback parameter '$params{callback}' is not a code ",
+ "reference")
+ unless UNIVERSAL::isa($params{callback}, 'CODE');
+ } else {
+ # Otherwise just assign a default approve callback.
+ $params{callback} = sub { 1 };
+ }
+
+ # Validate type parameter.
+ if (my $t = $params{type}) {
+ Carp::croak("Invalid handler type '$t'")
+ unless $t eq 'error' or $t eq 'info' or $t eq 'unknown'
+ or $t eq 'confirm';
+ } else {
+ $params{type} = 'info';
+ }
+
+ # Return the request object.
+ bless \%params, ref $pkg || $pkg;
+}
+
+##############################################################################
+
+=head2 Object Methods
+
+=head3 message
+
+ my $message = $req->message;
+
+Returns the message stored in the App::Info::Request object. The message is
+typically informational, or an error message, or a prompt message.
+
+=cut
+
+sub message { $_[0]->{message} }
+
+##############################################################################
+
+=head3 error
+
+ my $error = $req->error;
+
+Returns any error message associated with the App::Info::Request object. The
+error message is typically there to display for users when C<callback()>
+returns false.
+
+=cut
+
+sub error { $_[0]->{error} }
+
+##############################################################################
+
+=head3 type
+
+ my $type = $req->type;
+
+Returns a string representing the type of event that triggered this request.
+The types are the same as the event triggering methods defined in App::Info.
+As of this writing, the supported types are:
+
+=over
+
+=item info
+
+=item error
+
+=item unknown
+
+=item confirm
+
+=back
+
+Be sure to consult the App::Info documentation for more details on the event
+types.
+
+=cut
+
+sub type { $_[0]->{type} }
+
+##############################################################################
+
+=head3 callback
+
+ if ($req->callback($value)) {
+ print "Value '$value' is valid.\n";
+ } else {
+ print "Value '$value' is not valid.\n";
+ }
+
+Executes the callback anonymous subroutine supplied by the App::Info concrete
+base class that triggered the event. If the callback returns false, then
+C<$value> is invalid. If the callback returns true, then C<$value> is valid
+and can be assigned via the C<value()> method.
+
+Note that the C<value()> method itself calls C<callback()> if it was passed a
+value to assign. See its documentation below for more information.
+
+=cut
+
+sub callback {
+ my $self = shift;
+ my $code = $self->{callback};
+ local $_ = $_[0];
+ $code->(@_);
+}
+
+##############################################################################
+
+=head3 value
+
+ my $value = $req->value;
+ if ($req->value($value)) {
+ print "Value '$value' successfully assigned.\n";
+ } else {
+ print "Value '$value' not successfully assigned.\n";
+ }
+
+When called without an argument, C<value()> simply returns the value currently
+stored by the App::Info::Request object. Typically, the value is the default
+value for a confirm event, or a value assigned to an unknown event.
+
+When passed an argument, C<value()> attempts to store the the argument as a
+new value. However, C<value()> calls C<callback()> on the new value, and if
+C<callback()> returns false, then C<value()> returns false and does not store
+the new value. If C<callback()> returns true, on the other hand, then
+C<value()> goes ahead and stores the new value and returns true.
+
+=cut
+
+sub value {
+ my $self = shift;
+ if ($#_ >= 0) {
+ # grab the value.
+ my $value = shift;
+ # Validate the value.
+ if ($self->callback($value)) {
+ # The value is good. Assign it and return true.
+ $self->{value} = $value;
+ return 1;
+ } else {
+ # Invalid value. Return false.
+ return;
+ }
+ }
+ # Just return the value.
+ return $self->{value};
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info> documents the event triggering methods and how they
+construct App::Info::Request objects to pass to event handlers.
+
+L<App::Info::Handler:|App::Info::Handler> documents how to create custom event
+handlers, which must make use of the App::Info::Request object passed to their
+C<handler()> object methods.
+
+The following classes subclass App::Info::Handler, and thus offer good
+exemplars for using App::Info::Request objects when handling events.
+
+=over 4
+
+=item L<App::Info::Handler::Carp|App::Info::Handler::Carp>
+
+=item L<App::Info::Handler::Print|App::Info::Handler::Print>
+
+=item L<App::Info::Handler::Prompt|App::Info::Handler::Prompt>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
--- /dev/null
+package App::Info::Util;
+
+# $Id: Util.pm,v 1.1 2004-04-29 09:21:28 ivan Exp $
+
+=head1 NAME
+
+App::Info::Util - Utility class for App::Info subclasses
+
+=head1 SYNOPSIS
+
+ use App::Info::Util;
+
+ my $util = App::Info::Util->new;
+
+ # Subclasses File::Spec.
+ my @paths = $util->paths;
+
+ # First directory that exists in a list.
+ my $dir = $util->first_dir(@paths);
+
+ # First directory that exists in a path.
+ $dir = $util->first_path($ENV{PATH});
+
+ # First file that exists in a list.
+ my $file = $util->first_file('this.txt', '/that.txt', 'C:\\foo.txt');
+
+ # First file found among file base names and directories.
+ my $files = ['this.txt', 'that.txt'];
+ $file = $util->first_cat_file($files, @paths);
+
+=head1 DESCRIPTION
+
+This class subclasses L<File::Spec|File::Spec> and adds its own methods in
+order to offer utility methods to L<App::Info|App::Info> classes. Although
+intended to be used by App::Info subclasses, in truth App::Info::Util's
+utility may be considered more general, so feel free to use it elsewhere.
+
+The methods added in addition to the usual File::Spec suspects are designed to
+facilitate locating files and directories on the file system, as well as
+searching those files. The assumption is that, in order to provide useful
+metadata about a given software package, an App::Info subclass must find
+relevant files and directories and parse them with regular expressions. This
+class offers methods that simplify those tasks.
+
+=cut
+
+use strict;
+use File::Spec ();
+use vars qw(@ISA $VERSION);
+@ISA = qw(File::Spec);
+$VERSION = '0.22';
+
+my %path_dems = (MacOS => qr',',
+ MSWin32 => qr';',
+ os2 => qr';',
+ VMS => undef,
+ epoc => undef);
+
+my $path_dem = exists $path_dems{$^O} ? $path_dems{$^O} : qr':';
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+ my $util = App::Info::Util->new;
+
+This is a very simple constructor that merely returns an App::Info::Util
+object. Since, like its File::Spec super class, App::Info::Util manages no
+internal data itself, all methods may be used as class methods, if one prefers
+to. The constructor here is provided merely as a convenience.
+
+=cut
+
+sub new { bless {}, ref $_[0] || $_[0] }
+
+=head1 OBJECT METHODS
+
+In addition to all of the methods offered by its super class,
+L<File::Spec|File::Spec>, App::Info::Util offers the following methods.
+
+=head2 first_dir
+
+ my @paths = $util->paths;
+ my $dir = $util->first_dir(@dirs);
+
+Returns the first file system directory in @paths that exists on the local
+file system. Only the first item in @paths that exists as a directory will be
+returned; any other paths leading to non-directories will be ignored.
+
+=cut
+
+sub first_dir {
+ shift;
+ foreach (@_) { return $_ if -d }
+ return;
+}
+
+=head2 first_path
+
+ my $path = $ENV{PATH};
+ $dir = $util->first_path($path);
+
+Takes the $path string and splits it into a list of directory paths, based on
+the path demarcator on the local file system. Then calls C<first_dir()> to
+return the first directoy in the path list that exists on the local file
+system. The path demarcator is specified for the following file systems:
+
+=over 4
+
+=item MacOS: ","
+
+=item MSWin32: ";"
+
+=item os2: ";"
+
+=item VMS: undef
+
+This method always returns undef on VMS. Patches welcome.
+
+=item epoc: undef
+
+This method always returns undef on epoch. Patches welcome.
+
+=item Unix: ":"
+
+All other operating systems are assumed to be Unix-based.
+
+=back
+
+=cut
+
+sub first_path {
+ return unless $path_dem;
+ shift->first_dir(split /$path_dem/, shift)
+}
+
+=head2 first_file
+
+ my $file = $util->first_file(@filelist);
+
+Examines each of the files in @filelist and returns the first one that exists
+on the file system. The file must be a regular file -- directories will be
+ignored.
+
+=cut
+
+sub first_file {
+ shift;
+ foreach (@_) { return $_ if -f }
+ return;
+}
+
+=head2 first_exe
+
+ my $exe = $util->first_exe(@exelist);
+
+Examines each of the files in @exelist and returns the first one that exists
+on the file system as an executable file. Directories will be ignored.
+
+=cut
+
+sub first_exe {
+ shift;
+ foreach (@_) { return $_ if -f && -x }
+ return;
+}
+
+=head2 first_cat_path
+
+ my $file = $util->first_cat_path('ick.txt', @paths);
+ $file = $util->first_cat_path(['this.txt', 'that.txt'], @paths);
+
+The first argument to this method may be either a file or directory base name
+(that is, a file or directory name without a full path specification), or a
+reference to an array of file or directory base names. The remaining arguments
+constitute a list of directory paths. C<first_cat_path()> processes each of
+these directory paths, concatenates (by the method native to the local
+operating system) each of the file or directory base names, and returns the
+first one that exists on the file system.
+
+For example, let us say that we were looking for a file called either F<httpd>
+or F<apache>, and it could be in any of the following paths:
+F</usr/local/bin>, F</usr/bin/>, F</bin>. The method call looks like this:
+
+ my $httpd = $util->first_cat_path(['httpd', 'apache'], '/usr/local/bin',
+ '/usr/bin/', '/bin');
+
+If the OS is a Unix variant, C<first_cat_path()> will then look for the first
+file that exists in this order:
+
+=over 4
+
+=item /usr/local/bin/httpd
+
+=item /usr/local/bin/apache
+
+=item /usr/bin/httpd
+
+=item /usr/bin/apache
+
+=item /bin/httpd
+
+=item /bin/apache
+
+=back
+
+The first of these complete paths to be found will be returned. If none are
+found, then undef will be returned.
+
+=cut
+
+sub first_cat_path {
+ my $self = shift;
+ my $files = ref $_[0] ? shift() : [shift()];
+ foreach my $p (@_) {
+ foreach my $f (@$files) {
+ my $path = $self->catfile($p, $f);
+ return $path if -e $path;
+ }
+ }
+ return;
+}
+
+=head2 first_cat_dir
+
+ my $dir = $util->first_cat_dir('ick.txt', @paths);
+ $dir = $util->first_cat_dir(['this.txt', 'that.txt'], @paths);
+
+Funtionally identical to C<first_cat_path()>, except that it returns the
+directory path in which the first file was found, rather than the full
+concatenated path. Thus, in the above example, if the file found was
+F</usr/bin/httpd>, while C<first_cat_path()> would return that value,
+C<first_cat_dir()> would return F</usr/bin> instead.
+
+=cut
+
+sub first_cat_dir {
+ my $self = shift;
+ my $files = ref $_[0] ? shift() : [shift()];
+ foreach my $p (@_) {
+ foreach my $f (@$files) {
+ my $path = $self->catfile($p, $f);
+ return $p if -e $path;
+ }
+ }
+ return;
+}
+
+=head2 first_cat_exe
+
+ my $exe = $util->first_cat_exe('ick.txt', @paths);
+ $exe = $util->first_cat_exe(['this.txt', 'that.txt'], @paths);
+
+Funtionally identical to C<first_cat_path()>, except that it returns the full
+path to the first executable file found, rather than simply the first file
+found.
+
+=cut
+
+sub first_cat_exe {
+ my $self = shift;
+ my $files = ref $_[0] ? shift() : [shift()];
+ foreach my $p (@_) {
+ foreach my $f (@$files) {
+ my $path = $self->catfile($p, $f);
+ return $path if -f $path && -x $path;
+ }
+ }
+ return;
+}
+
+=head2 search_file
+
+ my $file = 'foo.txt';
+ my $regex = qr/(text\s+to\s+find)/;
+ my $value = $util->search_file($file, $regex);
+
+Opens C<$file> and executes the C<$regex> regular expression against each line
+in the file. Once the line matches and one or more values is returned by the
+match, the file is closed and the value or values returned.
+
+For example, say F<foo.txt> contains the line "Version 6.5, patch level 8",
+and you need to grab each of the three version parts. All three parts can
+be grabbed like this:
+
+ my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/;
+ my @nums = $util->search_file($file, $regex);
+
+Now C<@nums> will contain the values C<(6, 5, 8)>. Note that in a scalar
+context, the above search would yeild an array reference:
+
+ my $regex = qr/Version\s+(\d+)\.(\d+),[^\d]*(\d+)/;
+ my $nums = $util->search_file($file, $regex);
+
+So now C<$nums> contains C<[6, 5, 8]>. The same does not hold true if the
+match returns only one value, however. Say F<foo.txt> contains the line
+"king of the who?", and you wish to know who the king is king of. Either
+of the following two calls would get you the data you need:
+
+ my $minions = $util->search_file($file, qr/King\s+of\s+(.*)/);
+ my @minions = $util->search_file($file, qr/King\s+of\s+(.*)/);
+
+In the first case, because the regular expression contains only one set of
+parentheses, C<search_file()> will simply return that value: C<$minions>
+contains the string "the who?". In the latter case, C<@minions> of course
+contains a single element: C<("the who?")>.
+
+Note that a regular expression without parentheses -- that is, one that
+doesn't grab values and put them into $1, $2, etc., will never successfully
+match a line in this method. You must include something to parentetically
+match. If you just want to know the value of what was matched, parenthesize
+the whole thing and if the value returns, you have a match. Also, if you need
+to match patterns across lines, try using multiple regular expressions with
+C<multi_search_file()>, instead.
+
+=cut
+
+sub search_file {
+ my ($self, $file, $regex) = @_;
+ return unless $file && $regex;
+ open F, "<$file" or Carp::croak "Cannot open $file: $!\n";
+ my @ret;
+ while (<F>) {
+ # If we find a match, we're done.
+ (@ret) = /$regex/ and last;
+ }
+ close F;
+ # If the match returned an more than one value, always return the full
+ # array. Otherwise, return just the first value in a scalar context.
+ return unless @ret;
+ return wantarray ? @ret : $#ret <= 0 ? $ret[0] : \@ret;
+}
+
+=head2 multi_search_file
+
+ my @regexen = (qr/(one)/, qr/(two)\s+(three)/);
+ my @matches = $util->multi_search_file($file, @regexen);
+
+Like C<search_file()>, this mehod opens C<$file> and parses it for regular
+expresion matches. This method, however, can take a list of regular
+expressions to look for, and will return the values found for all of them.
+Regular expressions that match and return multiple values will be returned as
+array referernces, while those that match and return a single value will
+return just that single value.
+
+For example, say you are parsing a file with lines like the following:
+
+ #define XML_MAJOR_VERSION 1
+ #define XML_MINOR_VERSION 95
+ #define XML_MICRO_VERSION 2
+
+You need to get each of these numbers, but calling C<search_file()> for each
+of them would be wasteful, as each call to C<search_file()> opens the file and
+parses it. With C<multi_search_file()>, on the other hand, the file will be
+opened only once, and, once all of the regular expressions have returned
+matches, the file will be closed and the matches returned.
+
+Thus the above values can be collected like this:
+
+ my @regexen = ( qr/XML_MAJOR_VERSION\s+(\d+)$/,
+ qr/XML_MINOR_VERSION\s+(\d+)$/,
+ qr/XML_MICRO_VERSION\s+(\d+)$/ );
+
+ my @nums = $file->multi_search_file($file, @regexen);
+
+The result will be that C<@nums> contains C<(1, 95, 2)>. Note that
+C<multi_file_search()> tries to do the right thing by only parsing the file
+until all of the regular expressions have been matched. Thus, a large file
+with the values you need near the top can be parsed very quickly.
+
+As with C<search_file()>, C<multi_search_file()> can take regular expressions
+that match multiple values. These will be returned as array references. For
+example, say the file you're parsing has files like this:
+
+ FooApp Version 4
+ Subversion 2, Microversion 6
+
+To get all of the version numbers, you can either use three regular
+expressions, as in the previous example:
+
+ my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/,
+ qr/Subversion\s+(\d+),/,
+ qr/Microversion\s+(\d$)$/ );
+
+ my @nums = $file->multi_search_file($file, @regexen);
+
+In which case C<@nums> will contain C<(4, 2, 6)>. Or, you can use just two
+regular expressions:
+
+ my @regexen = ( qr/FooApp\s+Version\s+(\d+)$/,
+ qr/Subversion\s+(\d+),\s+Microversion\s+(\d$)$/ );
+
+ my @nums = $file->multi_search_file($file, @regexen);
+
+In which case C<@nums> will contain C<(4, [2, 6])>. Note that the two
+parentheses that return values in the second regular expression cause the
+matches to be returned as an array reference.
+
+=cut
+
+sub multi_search_file {
+ my ($self, $file, @regexen) = @_;
+ return unless $file && @regexen;
+ my @each = @regexen;
+ open F, "<$file" or Carp::croak "Cannot open $file: $!\n";
+ my %ret;
+ while (my $line = <F>) {
+ my @splice;
+ # Process each of the regular expresssions.
+ for (my $i = 0; $i < @each; $i++) {
+ if ((my @ret) = $line =~ /$each[$i]/) {
+ # We have a match! If there's one match returned, just grab
+ # it. If there's more than one, keep it as an array ref.
+ $ret{$each[$i]} = $#ret > 0 ? \@ret : $ret[0];
+ # We got values for this regex, so not its place in the @each
+ # array.
+ push @splice, $i;
+ }
+ }
+ # Remove any regexen that have already found a match.
+ for (@splice) { splice @each, $_, 1 }
+ # If there are no more regexes, we're done -- no need to keep
+ # processing lines in the file!
+ last unless @each;
+ }
+ close F;
+ return unless %ret;
+ return wantarray ? @ret{@regexen} : \@ret{@regexen};
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Report all bugs via the CPAN Request Tracker at
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-Info>.
+
+=head1 AUTHOR
+
+David Wheeler <L<david@wheeler.net|"david@wheeler.net">>
+
+=head1 SEE ALSO
+
+L<App::Info|App::Info>, L<File::Spec|File::Spec>,
+L<App::Info::HTTPD::Apache|App::Info::HTTPD::Apache>
+L<App::Info::RDBMS::PostgreSQL|App::Info::RDBMS::PostgreSQL>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under the
+same terms as Perl itself.
+
+=cut
--- /dev/null
+Revision history for Perl extension DBIx::DBSchema.
+
+0.23 Mon Feb 16 17:35:54 PST 2004
+ - Update Pg dependancy to 1.32
+ - Update the simple load test so it skips DBIx::DBSchema::DBD::Pg if
+ DBD::Pg 1.32 is not installed.
+
+0.22 Thu Oct 23 15:18:21 PDT 2003
+ - Pg reverse-engineering fix: varchar with no limit
+ - Pg needs (unreleased) DBD::Pg 1.30 (or deb 1.22-2... interesting)
+
+0.21 Thu Sep 19 05:04:18 PDT 2002
+ - Pg reverse-engineering fix: now sets default
+
+0.20 Mon Mar 4 04:58:34 2002
+ - documentation updates
+ - fix Column->new when using named params
+ - fix Pg driver reverse-engineering length of numeric columns:
+ translate 655362 to 10,2, etc.
+ - fix Pg driver reverse-engineering of text columns (don't have a
+ length)
+
+0.19 Tue Oct 23 08:49:12 2001
+ - documentation for %typemap
+ - preliminary Sybase driver from Charles Shapiro
+ <charles.shapiro@numethods.com> and Mitchell J. Friedman
+ <mitchell.friedman@numethods.com>.
+ - Fix Column::line to return a scalar as documented, not a list.
+ - Should finally eliminate the Use of uninitialized value at
+ ... DBIx/DBSchema/Column.pm line 251
+
+0.18 Fri Aug 10 17:07:28 2001
+ - Added Table::delcolumn
+ - patch from Charles Shapiro <cshapiro@numethods.com> to add
+ `ORDER BY a.attnum' to the SQL in DBIx::DBSchema::DBD::Pg::columns
+
+0.17 Sat Jul 7 17:55:33 2001
+ - Rework Table->new interface for named params
+ - Fixes for Pg blobs, yay!
+ - MySQL doesn't need non-standard index syntax anymore (since 3.22).
+ - patch from Mark Ethan Trostler <mark@zzo.com> for generating
+ tables without indices.
+
+0.16 Fri Jan 5 15:55:50 2001
+ - Don't overflow index names.
+
+0.15 Fri Nov 24 23:39:16 2000
+ - MySQL handling of BOOL type (change to TINYINT)
+
+0.14 Tue Oct 24 14:43:16 2000
+ - MySQL handling of SERIAL type (change to INTEGER AUTO_INCREMENT)
+
+0.13 Wed Oct 11 10:47:13 2000
+ - fixed up type mapping foo, added default values, added named
+ parameters to Column->new, fixed quoting of default values
+
+0.11 Sun Sep 28 02:16:25 2000
+ - oops, original verison got 0.10, so this one will get 0.11
+
+0.01 Sun Sep 17 07:57:35 2000
+ - original version; created by h2xs 1.19
+
--- /dev/null
+package DBIx::DBSchema;
+
+use strict;
+use vars qw(@ISA $VERSION);
+#use Exporter;
+use Carp qw(confess);
+use DBI;
+use FreezeThaw qw(freeze thaw cmpStr);
+use DBIx::DBSchema::Table;
+use DBIx::DBSchema::Column;
+use DBIx::DBSchema::ColGroup::Unique;
+use DBIx::DBSchema::ColGroup::Index;
+
+#@ISA = qw(Exporter);
+@ISA = ();
+
+$VERSION = "0.23";
+
+=head1 NAME
+
+DBIx::DBSchema - Database-independent schema objects
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema;
+
+ $schema = new DBIx::DBSchema @dbix_dbschema_table_objects;
+ $schema = new_odbc DBIx::DBSchema $dbh;
+ $schema = new_odbc DBIx::DBSchema $dsn, $user, $pass;
+ $schema = new_native DBIx::DBSchema $dbh;
+ $schema = new_native DBIx::DBSchema $dsn, $user, $pass;
+
+ $schema->save("filename");
+ $schema = load DBIx::DBSchema "filename";
+
+ $schema->addtable($dbix_dbschema_table_object);
+
+ @table_names = $schema->tables;
+
+ $DBIx_DBSchema_table_object = $schema->table("table_name");
+
+ @sql = $schema->sql($dbh);
+ @sql = $schema->sql($dsn, $username, $password);
+ @sql = $schema->sql($dsn); #doesn't connect to database - less reliable
+
+ $perl_code = $schema->pretty_print;
+ %hash = eval $perl_code;
+ use DBI qw(:sql_types); $schema = pretty_read DBIx::DBSchema \%hash;
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema objects are collections of DBIx::DBSchema::Table objects and
+represent a database schema.
+
+This module implements an OO-interface to database schemas. Using this module,
+you can create a database schema with an OO Perl interface. You can read the
+schema from an existing database. You can save the schema to disk and restore
+it a different process. Most importantly, DBIx::DBSchema can write SQL
+CREATE statements statements for different databases from a single source.
+
+Currently supported databases are MySQL and PostgreSQL. Sybase support is
+partially implemented. DBIx::DBSchema will attempt to use generic SQL syntax
+for other databases. Assistance adding support for other databases is
+welcomed. See L<DBIx::DBSchema::DBD>, "Driver Writer's Guide and Base Class".
+
+=head1 METHODS
+
+=over 4
+
+=item new TABLE_OBJECT, TABLE_OBJECT, ...
+
+Creates a new DBIx::DBSchema object.
+
+=cut
+
+sub new {
+ my($proto, @tables) = @_;
+ my %tables = map { $_->name, $_ } @tables; #check for duplicates?
+
+ my $class = ref($proto) || $proto;
+ my $self = {
+ 'tables' => \%tables,
+ };
+
+ bless ($self, $class);
+
+}
+
+=item new_odbc DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ]
+
+Creates a new DBIx::DBSchema object from an existing data source, which can be
+specified by passing an open DBI database handle, or by passing the DBI data
+source name, username, and password. This uses the experimental DBI type_info
+method to create a schema with standard (ODBC) SQL column types that most
+closely correspond to any non-portable column types. Use this to import a
+schema that you wish to use with many different database engines. Although
+primary key and (unique) index information will only be read from databases
+with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of
+column names and attributes *should* work for any database. Note that this
+method only uses "ODBC" column types; it does not require or use an ODBC
+driver.
+
+=cut
+
+sub new_odbc {
+ my($proto, $dbh) = (shift, shift);
+ $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr unless ref($dbh);
+ $proto->new(
+ map { new_odbc DBIx::DBSchema::Table $dbh, $_ } _tables_from_dbh($dbh)
+ );
+}
+
+=item new_native DATABASE_HANDLE | DATA_SOURCE USERNAME PASSWORD [ ATTR ]
+
+Creates a new DBIx::DBSchema object from an existing data source, which can be
+specified by passing an open DBI database handle, or by passing the DBI data
+source name, username and password. This uses database-native methods to read
+the schema, and will preserve any non-portable column types. The method is
+only available if there is a DBIx::DBSchema::DBD for the corresponding database engine (currently, MySQL and PostgreSQL).
+
+=cut
+
+sub new_native {
+ my($proto, $dbh) = (shift, shift);
+ $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr unless ref($dbh);
+ $proto->new(
+ map { new_native DBIx::DBSchema::Table ( $dbh, $_ ) } _tables_from_dbh($dbh)
+ );
+}
+
+=item load FILENAME
+
+Loads a DBIx::DBSchema object from a file.
+
+=cut
+
+sub load {
+ my($proto,$file)=@_; #use $proto ?
+ open(FILE,"<$file") or die "Can't open $file: $!";
+ my($string)=join('',<FILE>); #can $string have newlines? pry not?
+ close FILE or die "Can't close $file: $!";
+ my($self)=thaw $string;
+ #no bless needed?
+ $self;
+}
+
+=item save FILENAME
+
+Saves a DBIx::DBSchema object to a file.
+
+=cut
+
+sub save {
+ my($self,$file)=@_;
+ my($string)=freeze $self;
+ open(FILE,">$file") or die "Can't open $file: $!";
+ print FILE $string;
+ close FILE or die "Can't close file: $!";
+ my($check_self)=thaw $string;
+ die "Verify error: Can't freeze and thaw dbdef $self"
+ if (cmpStr($self,$check_self));
+}
+
+=item addtable TABLE_OBJECT
+
+Adds the given DBIx::DBSchema::Table object to this DBIx::DBSchema.
+
+=cut
+
+sub addtable {
+ my($self,$table)=@_;
+ $self->{'tables'}->{$table->name} = $table; #check for dupliates?
+}
+
+=item tables
+
+Returns a list of the names of all tables.
+
+=cut
+
+sub tables {
+ my($self)=@_;
+ keys %{$self->{'tables'}};
+}
+
+=item table TABLENAME
+
+Returns the specified DBIx::DBSchema::Table object.
+
+=cut
+
+sub table {
+ my($self,$table)=@_;
+ $self->{'tables'}->{$table};
+}
+
+=item sql [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
+
+Returns a list of SQL `CREATE' statements for this schema.
+
+The data source can be specified by passing an open DBI database handle, or by
+passing the DBI data source name, username and password.
+
+Although the username and password are optional, it is best to call this method
+with a database handle or data source including a valid username and password -
+a DBI connection will be opened and the quoting and type mapping will be more
+reliable.
+
+If passed a DBI data source (or handle) such as `DBI:mysql:database' or
+`DBI:Pg:dbname=database', will use syntax specific to that database engine.
+Currently supported databases are MySQL and PostgreSQL.
+
+If not passed a data source (or handle), or if there is no driver for the
+specified database, will attempt to use generic SQL syntax.
+
+=cut
+
+sub sql {
+ my($self, $dbh) = (shift, shift);
+ my $created_dbh = 0;
+ unless ( ref($dbh) || ! @_ ) {
+ $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr;
+ $created_dbh = 1;
+ }
+ my @r = map { $self->table($_)->sql_create_table($dbh); } $self->tables;
+ $dbh->disconnect if $created_dbh;
+ @r;
+}
+
+=item pretty_print
+
+Returns the data in this schema as Perl source, suitable for assigning to a
+hash.
+
+=cut
+
+sub pretty_print {
+ my($self) = @_;
+ join("},\n\n",
+ map {
+ my $table = $_;
+ "'$table' => {\n".
+ " 'columns' => [\n".
+ join("", map {
+ #cant because -w complains about , in qw()
+ # (also biiiig problems with empty lengths)
+ #" qw( $_ ".
+ #$self->table($table)->column($_)->type. " ".
+ #( $self->table($table)->column($_)->null ? 'NULL' : 0 ). " ".
+ #$self->table($table)->column($_)->length. " ),\n"
+ " '$_', ".
+ "'". $self->table($table)->column($_)->type. "', ".
+ "'". $self->table($table)->column($_)->null. "', ".
+ "'". $self->table($table)->column($_)->length. "', ".
+ "'". $self->table($table)->column($_)->default. "', ".
+ "'". $self->table($table)->column($_)->local. "',\n"
+ } $self->table($table)->columns
+ ).
+ " ],\n".
+ " 'primary_key' => '". $self->table($table)->primary_key. "',\n".
+ " 'unique' => [ ". join(', ',
+ map { "[ '". join("', '", @{$_}). "' ]" }
+ @{$self->table($table)->unique->lol_ref}
+ ). " ],\n".
+ " 'index' => [ ". join(', ',
+ map { "[ '". join("', '", @{$_}). "' ]" }
+ @{$self->table($table)->index->lol_ref}
+ ). " ],\n"
+ #" 'index' => [ ". " ],\n"
+ } $self->tables
+ ), "}\n";
+}
+
+=cut
+
+=item pretty_read HASHREF
+
+Creates a schema as specified by a data structure such as that created by
+B<pretty_print> method.
+
+=cut
+
+sub pretty_read {
+ my($proto, $href) = @_;
+ my $schema = $proto->new( map {
+ my(@columns);
+ while ( @{$href->{$_}{'columns'}} ) {
+ push @columns, DBIx::DBSchema::Column->new(
+ splice @{$href->{$_}{'columns'}}, 0, 6
+ );
+ }
+ DBIx::DBSchema::Table->new(
+ $_,
+ $href->{$_}{'primary_key'},
+ DBIx::DBSchema::ColGroup::Unique->new($href->{$_}{'unique'}),
+ DBIx::DBSchema::ColGroup::Index->new($href->{$_}{'index'}),
+ @columns,
+ );
+ } (keys %{$href}) );
+}
+
+# private subroutines
+
+sub _load_driver {
+ my($dbh) = @_;
+ my $driver;
+ if ( ref($dbh) ) {
+ $driver = $dbh->{Driver}->{Name};
+ } else {
+ $dbh =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect
+ or '' =~ /()/; # ensure $1 etc are empty if match fails
+ $driver = $1 or confess "can't parse data source: $dbh";
+ }
+
+ #require "DBIx/DBSchema/DBD/$driver.pm";
+ #$driver;
+ eval 'require "DBIx/DBSchema/DBD/$driver.pm"' and $driver or die $@;
+}
+
+sub _tables_from_dbh {
+ my($dbh) = @_;
+ my $sth = $dbh->table_info or die $dbh->errstr;
+ #map { $_->{TABLE_NAME} } grep { $_->{TABLE_TYPE} eq 'TABLE' }
+ # @{ $sth->fetchall_arrayref({ TABLE_NAME=>1, TABLE_TYPE=>1}) };
+ map { $_->[0] } grep { $_->[1] =~ /^TABLE$/i }
+ @{ $sth->fetchall_arrayref([2,3]) };
+}
+
+=back
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+Charles Shapiro <charles.shapiro@numethods.com> and Mitchell Friedman
+<mitchell.friedman@numethods.com> contributed the start of a Sybase driver.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+Each DBIx::DBSchema object should have a name which corresponds to its name
+within the SQL database engine (DBI data source).
+
+pretty_print is actually pretty ugly.
+
+Perhaps pretty_read should eval column types so that we can use DBI
+qw(:sql_types) here instead of externally.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup>,
+L<DBIx::DBSchema::ColGroup::Unique>, L<DBIx::DBSchema::ColGroup::Index>,
+L<DBIx::DBSchema::Column>, L<DBIx::DBSchema::DBD>,
+L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>, L<FS::Record>,
+L<DBI>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::ColGroup;
+
+use strict;
+use vars qw(@ISA);
+#use Exporter;
+
+#@ISA = qw(Exporter);
+@ISA = qw();
+
+=head1 NAME
+
+DBIx::DBSchema::ColGroup - Column group objects
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema::ColGroup;
+
+ $colgroup = new DBIx::DBSchema::ColGroup ( $lol_ref );
+ $colgroup = new DBIx::DBSchema::ColGroup ( \@lol );
+ $colgroup = new DBIx::DBSchema::ColGroup (
+ [
+ [ 'single_column' ],
+ [ 'multiple_columns', 'another_column', ],
+ ]
+ );
+
+ $lol_ref = $colgroup->lol_ref;
+
+ @sql_lists = $colgroup->sql_list;
+
+ @singles = $colgroup->singles;
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema::ColGroup objects represent sets of sets of columns. (IOW a
+"list of lists" - see L<perllol>.)
+
+=head1 METHODS
+
+=over 4
+
+=item new [ LOL_REF ]
+
+Creates a new DBIx::DBSchema::ColGroup object. Pass a reference to a list of
+lists of column names.
+
+=cut
+
+sub new {
+ my($proto, $lol) = @_;
+
+ my $class = ref($proto) || $proto;
+ my $self = {
+ 'lol' => $lol,
+ };
+
+ bless ($self, $class);
+
+}
+
+=item lol_ref
+
+Returns a reference to a list of lists of column names.
+
+=cut
+
+sub lol_ref {
+ my($self) = @_;
+ $self->{'lol'};
+}
+
+=item sql_list
+
+Returns a flat list of comma-separated values, for SQL statements.
+
+For example:
+
+ @lol = (
+ [ 'single_column' ],
+ [ 'multiple_columns', 'another_column', ],
+ );
+
+ $colgroup = new DBIx::DBSchema::ColGroup ( \@lol );
+
+ print join("\n", $colgroup->sql_list), "\n";
+
+Will print:
+
+ single_column
+ multiple_columns, another_column
+
+=cut
+
+sub sql_list { #returns a flat list of comman-separates lists (for sql)
+ my($self)=@_;
+ grep $_ ne '', map join(', ', @{$_}), @{$self->{'lol'}};
+}
+
+=item singles
+
+Returns a flat list of all single item lists.
+
+=cut
+
+sub singles { #returns single-field groups as a flat list
+ my($self)=@_;
+ #map ${$_}[0], grep scalar(@{$_}) == 1, @{$self->{'lol'}};
+ map {
+ ${$_}[0] =~ /^(\w+)$/
+ #aah!
+ or die "Illegal column ", ${$_}[0], " in colgroup!";
+ $1;
+ } grep scalar(@{$_}) == 1, @{$self->{'lol'}};
+}
+
+=back
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema::ColGroup::Unique>,
+L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema>, L<perllol>, L<perldsc>,
+L<DBI>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::ColGroup::Index;
+
+use strict;
+use vars qw(@ISA);
+use DBIx::DBSchema::ColGroup;
+
+@ISA=qw(DBIx::DBSchema::ColGroup);
+
+=head1 NAME
+
+DBIx::DBSchema::ColGroup::Index - Index column group object
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema::ColGroup::Index;
+
+ # see DBIx::DBSchema::ColGroup methods
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema::ColGroup::Index objects represent the (non-unique) indices of a
+database table (L<DBIx::DBSchema::Table>). DBIx::DBSchema::ColGroup::Index
+inherits from DBIx::DBSchema::ColGroup.
+
+=head1 BUGS
+
+Is this empty subclass needed?
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema::ColGroup>, L<DBIx::DBSchema::ColGroup::Unique>,
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<FS::Record>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::ColGroup::Unique;
+
+use strict;
+use vars qw(@ISA);
+use DBIx::DBSchema::ColGroup;
+
+@ISA=qw(DBIx::DBSchema::ColGroup);
+
+=head1 NAME
+
+DBIx::DBSchema::ColGroup::Unique - Unique column group object
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema::ColGroup::Unique;
+
+ # see DBIx::DBSchema::ColGroup methods
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema::ColGroup::Unique objects represent the unique indices of a
+database table (L<DBIx::DBSchema::Table>). DBIx::DBSchema::ColGroup:Unique
+inherits from DBIx::DBSchema::ColGroup.
+
+=head1 BUGS
+
+Is this empty subclass needed?
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema::ColGroup>, L<DBIx::DBSchema::ColGroup::Index>,
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<FS::Record>
+
+=cut
+
+1;
+
+
--- /dev/null
+package DBIx::DBSchema::Column;
+
+use strict;
+use vars qw(@ISA $VERSION);
+#use Carp;
+#use Exporter;
+
+#@ISA = qw(Exporter);
+@ISA = qw();
+
+$VERSION = '0.02';
+
+=head1 NAME
+
+DBIx::DBSchema::Column - Column objects
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema::Column;
+
+ #named params with a hashref (preferred)
+ $column = new DBIx::DBSchema::Column ( {
+ 'name' => 'column_name',
+ 'type' => 'varchar'
+ 'null' => 'NOT NULL',
+ 'length' => 64,
+ 'default' => '
+ 'local' => '',
+ } );
+
+ #list
+ $column = new DBIx::DBSchema::Column ( $name, $sql_type, $nullability, $length, $default, $local );
+
+ $name = $column->name;
+ $column->name( 'name' );
+
+ $sql_type = $column->type;
+ $column->type( 'sql_type' );
+
+ $null = $column->null;
+ $column->null( 'NULL' );
+ $column->null( 'NOT NULL' );
+ $column->null( '' );
+
+ $length = $column->length;
+ $column->length( '10' );
+ $column->length( '8,2' );
+
+ $default = $column->default;
+ $column->default( 'Roo' );
+
+ $sql_line = $column->line;
+ $sql_line = $column->line($datasrc);
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema::Column objects represent columns in tables (see
+L<DBIx::DBSchema::Table>).
+
+=head1 METHODS
+
+=over 4
+
+=item new HASHREF
+
+=item new [ name [ , type [ , null [ , length [ , default [ , local ] ] ] ] ] ]
+
+Creates a new DBIx::DBSchema::Column object. Takes a hashref of named
+parameters, or a list. B<name> is the name of the column. B<type> is the SQL
+data type. B<null> is the nullability of the column (intrepreted using Perl's
+rules for truth, with one exception: `NOT NULL' is false). B<length> is the
+SQL length of the column. B<default> is the default value of the column.
+B<local> is reserved for database-specific information.
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ my $self;
+ if ( ref($_[0]) ) {
+ $self = shift;
+ } else {
+ $self = { map { $_ => shift } qw(name type null length default local) };
+ }
+
+ #croak "Illegal name: ". $self->{'name'}
+ # if grep $self->{'name'} eq $_, @reserved_words;
+
+ $self->{'null'} =~ s/^NOT NULL$//i;
+ $self->{'null'} = 'NULL' if $self->{'null'};
+
+ bless ($self, $class);
+
+}
+
+=item name [ NAME ]
+
+Returns or sets the column name.
+
+=cut
+
+sub name {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ #croak "Illegal name: $name" if grep $name eq $_, @reserved_words;
+ $self->{'name'} = $value;
+ } else {
+ $self->{'name'};
+ }
+}
+
+=item type [ TYPE ]
+
+Returns or sets the column type.
+
+=cut
+
+sub type {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{'type'} = $value;
+ } else {
+ $self->{'type'};
+ }
+}
+
+=item null [ NULL ]
+
+Returns or sets the column null flag (the empty string is equivalent to
+`NOT NULL')
+
+=cut
+
+sub null {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $value =~ s/^NOT NULL$//i;
+ $value = 'NULL' if $value;
+ $self->{'null'} = $value;
+ } else {
+ $self->{'null'};
+ }
+}
+
+=item length [ LENGTH ]
+
+Returns or sets the column length.
+
+=cut
+
+sub length {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{'length'} = $value;
+ } else {
+ $self->{'length'};
+ }
+}
+
+=item default [ LOCAL ]
+
+Returns or sets the default value.
+
+=cut
+
+sub default {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{'default'} = $value;
+ } else {
+ $self->{'default'};
+ }
+}
+
+
+=item local [ LOCAL ]
+
+Returns or sets the database-specific field.
+
+=cut
+
+sub local {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{'local'} = $value;
+ } else {
+ $self->{'local'};
+ }
+}
+
+=item line [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
+
+Returns an SQL column definition.
+
+The data source can be specified by passing an open DBI database handle, or by
+passing the DBI data source name, username and password.
+
+Although the username and password are optional, it is best to call this method
+with a database handle or data source including a valid username and password -
+a DBI connection will be opened and the quoting and type mapping will be more
+reliable.
+
+If passed a DBI data source (or handle) such as `DBI:mysql:database' or
+`DBI:Pg:dbname=database', will use syntax specific to that database engine.
+Currently supported databases are MySQL and PostgreSQL. Non-standard syntax
+for other engines (if applicable) may also be supported in the future.
+
+=cut
+
+sub line {
+ my($self,$dbh) = (shift, shift);
+
+ my $created_dbh = 0;
+ unless ( ref($dbh) || ! @_ ) {
+ $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr;
+ my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error
+ $created_dbh = 1;
+ }
+
+ my $driver = DBIx::DBSchema::_load_driver($dbh);
+ my %typemap;
+ %typemap = eval "\%DBIx::DBSchema::DBD::${driver}::typemap" if $driver;
+ my $type = defined( $typemap{uc($self->type)} )
+ ? $typemap{uc($self->type)}
+ : $self->type;
+
+ my $null = $self->null;
+
+ my $default;
+ if ( defined($self->default) && $self->default ne ''
+ && ref($dbh)
+ # false laziness: nicked from FS::Record::_quote
+ && ( $self->default !~ /^\-?\d+(\.\d+)?$/
+ || $type =~ /(char|binary|blob|text)$/i
+ )
+ ) {
+ $default = $dbh->quote($self->default);
+ } else {
+ $default = $self->default;
+ }
+
+ #this should be a callback into the driver
+ if ( $driver eq 'mysql' ) { #yucky mysql hack
+ $null ||= "NOT NULL";
+ $self->local('AUTO_INCREMENT') if uc($self->type) eq 'SERIAL';
+ } elsif ( $driver eq 'Pg' ) { #yucky Pg hack
+ $null ||= "NOT NULL";
+ $null =~ s/^NULL$//;
+ }
+
+ my $r = join(' ',
+ $self->name,
+ $type. ( ( defined($self->length) && $self->length )
+ ? '('.$self->length.')'
+ : ''
+ ),
+ $null,
+ ( ( defined($default) && $default ne '' )
+ ? 'DEFAULT '. $default
+ : ''
+ ),
+ ( ( $driver eq 'mysql' && defined($self->local) )
+ ? $self->local
+ : ''
+ ),
+ );
+ $dbh->disconnect if $created_dbh;
+ $r;
+
+}
+
+=back
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+line() has database-specific foo that probably ought to be abstracted into
+the DBIx::DBSchema:DBD:: modules.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema::Table>, L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::DBD;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = '0.02';
+
+=head1 NAME
+
+DBIx::DBSchema::DBD - DBIx::DBSchema Driver Writer's Guide and Base Class
+
+=head1 SYNOPSIS
+
+ perldoc DBIx::DBSchema::DBD
+
+ package DBIx::DBSchema::DBD::FooBase
+ use DBIx::DBSchmea::DBD;
+ @ISA = qw(DBIx::DBSchema::DBD);
+
+=head1 DESCRIPTION
+
+Drivers should be named DBIx::DBSchema::DBD::DatabaseName, where DatabaseName
+is the same as the DBD:: driver for this database. Drivers should implement the
+following class methods:
+
+=over 4
+
+=item columns CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return a listref of listrefs (see
+L<perllol>), each containing six elements: column name, column type,
+nullability, column length, column default, and a field reserved for
+driver-specific use.
+
+=item column CLASS DBI_DBH TABLE COLUMN
+
+Same as B<columns> above, except return the listref for a single column. You
+can inherit from DBIx::DBSchema::DBD to provide this function.
+
+=cut
+
+sub column {
+ my($proto, $dbh, $table, $column) = @_;
+ #@a = grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) };
+ #$a[0];
+ @{ [
+ grep { $_->[0] eq $column } @{ $proto->columns( $dbh, $table ) }
+ ] }[0]; #force list context on grep, return scalar of first element
+}
+
+=item primary_key CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return the primary key for the specified
+table.
+
+=item unique CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return a hashref of unique indices. The
+keys of the hashref are index names, and the values are arrayrefs which point
+a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and
+L<DBIx::DBSchema::ColGroup>.
+
+=item index CLASS DBI_DBH TABLE
+
+Given an active DBI database handle, return a hashref of (non-unique) indices.
+The keys of the hashref are index names, and the values are arrayrefs which
+point a list of column names for each. See L<perldsc/"HASHES OF LISTS"> and
+L<DBIx::DBSchema::ColGroup>.
+
+=back
+
+=head1 TYPE MAPPING
+
+You can define a %typemap array for your driver to map "standard" data
+types to database-specific types. For example, the MySQL TIMESTAMP field
+has non-standard auto-updating semantics; the MySQL DATETIME type is
+what other databases and the ODBC standard call TIMESTAMP, so one of the
+entries in the MySQL %typemap is:
+
+ 'TIMESTAMP' => 'DATETIME',
+
+Another example is the Pg %typemap which maps the standard types BLOB and
+LONG VARBINARY to the Pg-specific BYTEA:
+
+ 'BLOB' => 'BYTEA',
+ 'LONG VARBINARY' => 'BYTEA',
+
+Make sure you use all uppercase-keys.
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD::mysql>, L<DBIx::DBSchema::DBD::Pg>,
+L<DBIx::DBSchema::ColGroup>, L<DBI>, L<DBI::DBD>, L<perllol>,
+L<perldsc/"HASHES OF LISTS">
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::DBD::Pg;
+
+use strict;
+use vars qw($VERSION @ISA %typemap);
+use DBD::Pg 1.22;
+use DBIx::DBSchema::DBD;
+
+$VERSION = '0.08';
+@ISA = qw(DBIx::DBSchema::DBD);
+
+%typemap = (
+ 'BLOB' => 'BYTEA',
+ 'LONG VARBINARY' => 'BYTEA',
+);
+
+=head1 NAME
+
+DBIx::DBSchema::DBD::Pg - PostgreSQL native driver for DBIx::DBSchema
+
+=head1 SYNOPSIS
+
+use DBI;
+use DBIx::DBSchema;
+
+$dbh = DBI->connect('dbi:Pg:dbname=database', 'user', 'pass');
+$schema = new_native DBIx::DBSchema $dbh;
+
+=head1 DESCRIPTION
+
+This module implements a PostgreSQL-native driver for DBIx::DBSchema.
+
+=cut
+
+sub columns {
+ my($proto, $dbh, $table) = @_;
+ my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
+ SELECT a.attname, t.typname, a.attlen, a.atttypmod, a.attnotnull,
+ a.atthasdef, a.attnum
+ FROM pg_class c, pg_attribute a, pg_type t
+ WHERE c.relname = '$table'
+ AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
+ ORDER BY a.attnum
+END
+ $sth->execute or die $sth->errstr;
+
+ map {
+
+ my $default = '';
+ if ( $_->{atthasdef} ) {
+ my $attnum = $_->{attnum};
+ my $d_sth = $dbh->prepare(<<END) or die $dbh->errstr;
+ SELECT substring(d.adsrc for 128) FROM pg_attrdef d, pg_class c
+ WHERE c.relname = '$table' AND c.oid = d.adrelid AND d.adnum = $attnum
+END
+ $d_sth->execute or die $d_sth->errstr;
+
+ $default = $d_sth->fetchrow_arrayref->[0];
+ };
+
+ my $len = '';
+ if ( $_->{attlen} == -1 && $_->{atttypmod} != -1
+ && $_->{typname} ne 'text' ) {
+ $len = $_->{atttypmod} - 4;
+ if ( $_->{typname} eq 'numeric' ) {
+ $len = ($len >> 16). ','. ($len & 0xffff);
+ }
+ }
+
+ my $type = $_->{'typname'};
+ $type = 'char' if $type eq 'bpchar';
+
+ [
+ $_->{'attname'},
+ $type,
+ ! $_->{'attnotnull'},
+ $len,
+ $default,
+ '' #local
+ ];
+
+ } @{ $sth->fetchall_arrayref({}) };
+}
+
+sub primary_key {
+ my($proto, $dbh, $table) = @_;
+ my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
+ SELECT a.attname, a.attnum
+ FROM pg_class c, pg_attribute a, pg_type t
+ WHERE c.relname = '${table}_pkey'
+ AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
+END
+ $sth->execute or die $sth->errstr;
+ my $row = $sth->fetchrow_hashref or return '';
+ $row->{'attname'};
+}
+
+sub unique {
+ my($proto, $dbh, $table) = @_;
+ my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
+ grep { $proto->_is_unique($dbh, $_ ) }
+ $proto->_all_indices($dbh, $table)
+ };
+}
+
+sub index {
+ my($proto, $dbh, $table) = @_;
+ my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $_ ) ] }
+ grep { ! $proto->_is_unique($dbh, $_ ) }
+ $proto->_all_indices($dbh, $table)
+ };
+}
+
+sub _all_indices {
+ my($proto, $dbh, $table) = @_;
+ my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
+ SELECT c2.relname
+ FROM pg_class c, pg_class c2, pg_index i
+ WHERE c.relname = '$table' AND c.oid = i.indrelid AND i.indexrelid = c2.oid
+END
+ $sth->execute or die $sth->errstr;
+ map { $_->{'relname'} }
+ grep { $_->{'relname'} !~ /_pkey$/ }
+ @{ $sth->fetchall_arrayref({}) };
+}
+
+sub _index_fields {
+ my($proto, $dbh, $index) = @_;
+ my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
+ SELECT a.attname, a.attnum
+ FROM pg_class c, pg_attribute a, pg_type t
+ WHERE c.relname = '$index'
+ AND a.attnum > 0 AND a.attrelid = c.oid AND a.atttypid = t.oid
+END
+ $sth->execute or die $sth->errstr;
+ map { $_->{'attname'} } @{ $sth->fetchall_arrayref({}) };
+}
+
+sub _is_unique {
+ my($proto, $dbh, $index) = @_;
+ my $sth = $dbh->prepare(<<END) or die $dbh->errstr;
+ SELECT i.indisunique
+ FROM pg_index i, pg_class c, pg_am a
+ WHERE i.indexrelid = c.oid AND c.relname = '$index' AND c.relam = a.oid
+END
+ $sth->execute or die $sth->errstr;
+ my $row = $sth->fetchrow_hashref or die 'guru meditation #420';
+ $row->{'indisunique'};
+}
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+Yes.
+
+columns doesn't return column default information.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::DBD::Sybase;
+
+use strict;
+use vars qw($VERSION @ISA %typemap);
+use DBIx::DBSchema::DBD;
+
+$VERSION = '0.03';
+@ISA = qw(DBIx::DBSchema::DBD);
+
+%typemap = (
+# 'empty' => 'empty'
+);
+
+=head1 NAME
+
+DBIx::DBSchema::DBD::Sybase - Sybase database driver for DBIx::DBSchema
+
+=head1 SYNOPSIS
+
+use DBI;
+use DBIx::DBSchema;
+
+$dbh = DBI->connect('dbi:Sybase:dbname=database', 'user', 'pass');
+$schema = new_native DBIx::DBSchema $dbh;
+
+=head1 DESCRIPTION
+
+This module implements a Sybase driver for DBIx::DBSchema.
+
+=cut
+
+sub columns {
+ my($proto, $dbh, $table) = @_;
+
+ my $sth = $dbh->prepare("sp_columns \@table_name=$table")
+ or die $dbh->errstr;
+
+ $sth->execute or die $sth->errstr;
+ my @cols = map {
+ [
+ $_->{'column_name'},
+ $_->{'type_name'},
+ ($_->{'nullable'} ? 1 : ''),
+ $_->{'length'},
+ '', #default
+ '' #local
+ ]
+ } @{ $sth->fetchall_arrayref({}) };
+ $sth->finish;
+
+ @cols;
+}
+
+sub primary_key {
+ return("StubbedPrimaryKey");
+}
+
+
+sub unique {
+ my($proto, $dbh, $table) = @_;
+ my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] }
+ grep { $proto->_is_unique($dbh, $_ ) }
+ $proto->_all_indices($dbh, $table)
+ };
+}
+
+sub index {
+ my($proto, $dbh, $table) = @_;
+ my $gratuitous = { map { $_ => [ $proto->_index_fields($dbh, $table, $_ ) ] }
+ grep { ! $proto->_is_unique($dbh, $_ ) }
+ $proto->_all_indices($dbh, $table)
+ };
+}
+
+sub _all_indices {
+ my($proto, $dbh, $table) = @_;
+
+ my $sth = $dbh->prepare_cached(<<END) or die $dbh->errstr;
+ SELECT name
+ FROM sysindexes
+ WHERE id = object_id('$table') and indid between 1 and 254
+END
+ $sth->execute or die $sth->errstr;
+ my @indices = map { $_->[0] } @{ $sth->fetchall_arrayref() };
+ $sth->finish;
+ $sth = undef;
+ @indices;
+}
+
+sub _index_fields {
+ my($proto, $dbh, $table, $index) = @_;
+
+ my @keys;
+
+ my ($indid) = $dbh->selectrow_array("select indid from sysindexes where id = object_id('$table') and name = '$index'");
+ for (1..30) {
+ push @keys, $dbh->selectrow_array("select index_col('$table', $indid, $_)") || ();
+ }
+
+ return @keys;
+}
+
+sub _is_unique {
+ my($proto, $dbh, $table, $index) = @_;
+
+ my ($isunique) = $dbh->selectrow_array("select status & 2 from sysindexes where id = object_id('$table') and name = '$index'");
+
+ return $isunique;
+}
+
+=head1 AUTHOR
+
+Charles Shapiro <charles.shapiro@numethods.com>
+(courtesy of Ivan Kohler <ivan-dbix-dbschema@420.am>)
+
+Mitchell Friedman <mitchell.friedman@numethods.com>
+
+Bernd Dulfer <bernd@widd.de>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001 Charles Shapiro, Mitchell J. Friedman
+Copyright (c) 2001 nuMethods LLC.
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+Yes.
+
+The B<primary_key> method does not yet work.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::DBD::mysql;
+
+use strict;
+use vars qw($VERSION @ISA %typemap);
+use DBIx::DBSchema::DBD;
+
+$VERSION = '0.03';
+@ISA = qw(DBIx::DBSchema::DBD);
+
+%typemap = (
+ 'TIMESTAMP' => 'DATETIME',
+ 'SERIAL' => 'INTEGER',
+ 'BOOL' => 'TINYINT',
+ 'LONG VARBINARY' => 'LONGBLOB',
+);
+
+=head1 NAME
+
+DBIx::DBSchema::DBD::mysql - MySQL native driver for DBIx::DBSchema
+
+=head1 SYNOPSIS
+
+use DBI;
+use DBIx::DBSchema;
+
+$dbh = DBI->connect('dbi:mysql:database', 'user', 'pass');
+$schema = new_native DBIx::DBSchema $dbh;
+
+=head1 DESCRIPTION
+
+This module implements a MySQL-native driver for DBIx::DBSchema.
+
+=cut
+
+sub columns {
+ my($proto, $dbh, $table ) = @_;
+ my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr;
+ $sth->execute or die $sth->errstr;
+ map {
+ $_->{'Type'} =~ /^(\w+)\(?([\d\,]+)?\)?( unsigned)?$/
+ or die "Illegal type: ". $_->{'Type'}. "\n";
+ my($type, $length) = ($1, $2);
+ [
+ $_->{'Field'},
+ $type,
+ $_->{'Null'},
+ $length,
+ $_->{'Default'},
+ $_->{'Extra'}
+ ]
+ } @{ $sth->fetchall_arrayref( {} ) };
+}
+
+#sub primary_key {
+# my($proto, $dbh, $table ) = @_;
+# my $primary_key = '';
+# my $sth = $dbh->prepare("SHOW INDEX FROM $table")
+# or die $dbh->errstr;
+# $sth->execute or die $sth->errstr;
+# my @pkey = map { $_->{'Column_name'} } grep {
+# $_->{'Key_name'} eq "PRIMARY"
+# } @{ $sth->fetchall_arrayref( {} ) };
+# scalar(@pkey) ? $pkey[0] : '';
+#}
+
+sub primary_key {
+ my($proto, $dbh, $table) = @_;
+ my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
+ $pkey;
+}
+
+sub unique {
+ my($proto, $dbh, $table) = @_;
+ my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
+ $unique_href;
+}
+
+sub index {
+ my($proto, $dbh, $table) = @_;
+ my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
+ $index_href;
+}
+
+sub _show_index {
+ my($proto, $dbh, $table ) = @_;
+ my $sth = $dbh->prepare("SHOW INDEX FROM $table")
+ or die $dbh->errstr;
+ $sth->execute or die $sth->errstr;
+
+ my $pkey = '';
+ my(%index, %unique);
+ foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) {
+ if ( $row->{'Key_name'} eq 'PRIMARY' ) {
+ $pkey = $row->{'Column_name'};
+ } elsif ( $row->{'Non_unique'} ) { #index
+ push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'};
+ } else { #unique
+ push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'};
+ }
+ }
+
+ ( $pkey, \%unique, \%index );
+}
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
+
+=cut
+
+1;
+
--- /dev/null
+package DBIx::DBSchema::Table;
+
+use strict;
+use vars qw(@ISA %create_params);
+#use Carp;
+#use Exporter;
+use DBIx::DBSchema::Column 0.02;
+use DBIx::DBSchema::ColGroup::Unique;
+use DBIx::DBSchema::ColGroup::Index;
+
+#@ISA = qw(Exporter);
+@ISA = qw();
+
+=head1 NAME
+
+DBIx::DBSchema::Table - Table objects
+
+=head1 SYNOPSIS
+
+ use DBIx::DBSchema::Table;
+
+ #old style (depriciated)
+ $table = new DBIx::DBSchema::Table (
+ "table_name",
+ "primary_key",
+ $dbix_dbschema_colgroup_unique_object,
+ $dbix_dbschema_colgroup_index_object,
+ @dbix_dbschema_column_objects,
+ );
+
+ #new style (preferred), pass a hashref of parameters
+ $table = new DBIx::DBSchema::Table (
+ {
+ name => "table_name",
+ primary_key => "primary_key",
+ unique => $dbix_dbschema_colgroup_unique_object,
+ 'index' => $dbix_dbschema_colgroup_index_object,
+ columns => \@dbix_dbschema_column_objects,
+ }
+ );
+
+ $table->addcolumn ( $dbix_dbschema_column_object );
+
+ $table_name = $table->name;
+ $table->name("table_name");
+
+ $primary_key = $table->primary_key;
+ $table->primary_key("primary_key");
+
+ $dbix_dbschema_colgroup_unique_object = $table->unique;
+ $table->unique( $dbix_dbschema__colgroup_unique_object );
+
+ $dbix_dbschema_colgroup_index_object = $table->index;
+ $table->index( $dbix_dbschema_colgroup_index_object );
+
+ @column_names = $table->columns;
+
+ $dbix_dbschema_column_object = $table->column("column");
+
+ #preferred
+ @sql_statements = $table->sql_create_table( $dbh );
+ @sql_statements = $table->sql_create_table( $datasrc, $username, $password );
+
+ #possible problems
+ @sql_statements = $table->sql_create_table( $datasrc );
+ @sql_statements = $table->sql_create_table;
+
+=head1 DESCRIPTION
+
+DBIx::DBSchema::Table objects represent a single database table.
+
+=head1 METHODS
+
+=over 4
+
+=item new [ TABLE_NAME [ , PRIMARY_KEY [ , UNIQUE [ , INDEX [ , COLUMN... ] ] ] ] ]
+
+=item new HASHREF
+
+Creates a new DBIx::DBSchema::Table object. The preferred usage is to pass a
+hash reference of named parameters.
+
+ {
+ name => TABLE_NAME,
+ primary_key => PRIMARY_KEY,
+ unique => UNIQUE,
+ 'index' => INDEX,
+ columns => COLUMNS
+ }
+
+TABLE_NAME is the name of the table. PRIMARY_KEY is the primary key (may be
+empty). UNIQUE is a DBIx::DBSchema::ColGroup::Unique object (see
+L<DBIx::DBSchema::ColGroup::Unique>). INDEX is a
+DBIx::DBSchema::ColGroup::Index object (see
+L<DBIx::DBSchema::ColGroup::Index>). COLUMNS is a reference to an array of
+DBIx::DBSchema::Column objects (see L<DBIx::DBSchema::Column>).
+
+=cut
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+
+ my $self;
+ if ( ref($_[0]) ) {
+
+ $self = shift;
+ $self->{column_order} = [ map { $_->name } @{$self->{columns}} ];
+ $self->{columns} = { map { $_->name, $_ } @{$self->{columns}} };
+
+ } else {
+
+ my($name,$primary_key,$unique,$index,@columns) = @_;
+
+ my %columns = map { $_->name, $_ } @columns;
+ my @column_order = map { $_->name } @columns;
+
+ $self = {
+ 'name' => $name,
+ 'primary_key' => $primary_key,
+ 'unique' => $unique,
+ 'index' => $index,
+ 'columns' => \%columns,
+ 'column_order' => \@column_order,
+ };
+
+ }
+
+ #check $primary_key, $unique and $index to make sure they are $columns ?
+ # (and sanity check?)
+
+ bless ($self, $class);
+
+}
+
+=item new_odbc DATABASE_HANDLE TABLE_NAME
+
+Creates a new DBIx::DBSchema::Table object from the supplied DBI database
+handle for the specified table. This uses the experimental DBI type_info
+method to create a table with standard (ODBC) SQL column types that most
+closely correspond to any non-portable column types. Use this to import a
+schema that you wish to use with many different database engines. Although
+primary key and (unique) index information will only be imported from databases
+with DBIx::DBSchema::DBD drivers (currently MySQL and PostgreSQL), import of
+column names and attributes *should* work for any database.
+
+Note: the _odbc refers to the column types used and nothing else - you do not
+have to have ODBC installed or connect to the database via ODBC.
+
+=cut
+
+%create_params = (
+# undef => sub { '' },
+ '' => sub { '' },
+ 'max length' => sub { $_[0]->{PRECISION}->[$_[1]]; },
+ 'precision,scale' =>
+ sub { $_[0]->{PRECISION}->[$_[1]]. ','. $_[0]->{SCALE}->[$_[1]]; }
+);
+
+sub new_odbc {
+ my( $proto, $dbh, $name) = @_;
+ my $driver = DBIx::DBSchema::_load_driver($dbh);
+ my $sth = _null_sth($dbh, $name);
+ my $sthpos = 0;
+ $proto->new (
+ $name,
+ scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"),
+ DBIx::DBSchema::ColGroup::Unique->new(
+ $driver
+ ? [values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"}]
+ : []
+ ),
+ DBIx::DBSchema::ColGroup::Index->new(
+ $driver
+ ? [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ]
+ : []
+ ),
+ map {
+ my $type_info = scalar($dbh->type_info($sth->{TYPE}->[$sthpos]))
+ or die "DBI::type_info ". $dbh->{Driver}->{Name}. " driver ".
+ "returned no results for type ". $sth->{TYPE}->[$sthpos];
+ new DBIx::DBSchema::Column
+ $_,
+ $type_info->{'TYPE_NAME'},
+ #"SQL_". uc($type_info->{'TYPE_NAME'}),
+ $sth->{NULLABLE}->[$sthpos],
+ &{ $create_params{ $type_info->{CREATE_PARAMS} } }( $sth, $sthpos++ ), $driver && #default
+ ${ [
+ eval "DBIx::DBSchema::DBD::$driver->column(\$dbh, \$name, \$_)"
+ ] }[4]
+ # DB-local
+ } @{$sth->{NAME}}
+ );
+}
+
+=item new_native DATABASE_HANDLE TABLE_NAME
+
+Creates a new DBIx::DBSchema::Table object from the supplied DBI database
+handle for the specified table. This uses database-native methods to read the
+schema, and will preserve any non-portable column types. The method is only
+available if there is a DBIx::DBSchema::DBD for the corresponding database
+engine (currently, MySQL and PostgreSQL).
+
+=cut
+
+sub new_native {
+ my( $proto, $dbh, $name) = @_;
+ my $driver = DBIx::DBSchema::_load_driver($dbh);
+ $proto->new (
+ $name,
+ scalar(eval "DBIx::DBSchema::DBD::$driver->primary_key(\$dbh, \$name)"),
+ DBIx::DBSchema::ColGroup::Unique->new(
+ [ values %{eval "DBIx::DBSchema::DBD::$driver->unique(\$dbh, \$name)"} ]
+ ),
+ DBIx::DBSchema::ColGroup::Index->new(
+ [ values %{eval "DBIx::DBSchema::DBD::$driver->index(\$dbh, \$name)"} ]
+ ),
+ map {
+ DBIx::DBSchema::Column->new( @{$_} )
+ } eval "DBIx::DBSchema::DBD::$driver->columns(\$dbh, \$name)"
+ );
+}
+
+=item addcolumn COLUMN
+
+Adds this DBIx::DBSchema::Column object.
+
+=cut
+
+sub addcolumn {
+ my($self,$column)=@_;
+ ${$self->{'columns'}}{$column->name}=$column; #sanity check?
+ push @{$self->{'column_order'}}, $column->name;
+}
+
+=item delcolumn COLUMN_NAME
+
+Deletes this column. Returns false if no column of this name was found to
+remove, true otherwise.
+
+=cut
+
+sub delcolumn {
+ my($self,$column) = @_;
+ return 0 unless exists $self->{'columns'}{$column};
+ delete $self->{'columns'}{$column};
+ @{$self->{'column_order'}}= grep { $_ ne $column } @{$self->{'column_order'}}; 1;
+}
+
+=item name [ TABLE_NAME ]
+
+Returns or sets the table name.
+
+=cut
+
+sub name {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{name} = $value;
+ } else {
+ $self->{name};
+ }
+}
+
+=item primary_key [ PRIMARY_KEY ]
+
+Returns or sets the primary key.
+
+=cut
+
+sub primary_key {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{primary_key} = $value;
+ } else {
+ #$self->{primary_key};
+ #hmm. maybe should untaint the entire structure when it comes off disk
+ # cause if you don't trust that, ?
+ $self->{primary_key} =~ /^(\w*)$/
+ #aah!
+ or die "Illegal primary key: ", $self->{primary_key};
+ $1;
+ }
+}
+
+=item unique [ UNIQUE ]
+
+Returns or sets the DBIx::DBSchema::ColGroup::Unique object.
+
+=cut
+
+sub unique {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{unique} = $value;
+ } else {
+ $self->{unique};
+ }
+}
+
+=item index [ INDEX ]
+
+Returns or sets the DBIx::DBSchema::ColGroup::Index object.
+
+=cut
+
+sub index {
+ my($self,$value)=@_;
+ if ( defined($value) ) {
+ $self->{'index'} = $value;
+ } else {
+ $self->{'index'};
+ }
+}
+
+=item columns
+
+Returns a list consisting of the names of all columns.
+
+=cut
+
+sub columns {
+ my($self)=@_;
+ #keys %{$self->{'columns'}};
+ #must preserve order
+ @{ $self->{'column_order'} };
+}
+
+=item column COLUMN_NAME
+
+Returns the column object (see L<DBIx::DBSchema::Column>) for the specified
+COLUMN_NAME.
+
+=cut
+
+sub column {
+ my($self,$column)=@_;
+ $self->{'columns'}->{$column};
+}
+
+=item sql_create_table [ DATABASE_HANDLE | DATA_SOURCE [ USERNAME PASSWORD [ ATTR ] ] ]
+
+Returns a list of SQL statments to create this table.
+
+The data source can be specified by passing an open DBI database handle, or by
+passing the DBI data source name, username and password.
+
+Although the username and password are optional, it is best to call this method
+with a database handle or data source including a valid username and password -
+a DBI connection will be opened and the quoting and type mapping will be more
+reliable.
+
+If passed a DBI data source (or handle) such as `DBI:mysql:database', will use
+MySQL- or PostgreSQL-specific syntax. Non-standard syntax for other engines
+(if applicable) may also be supported in the future.
+
+=cut
+
+sub sql_create_table {
+ my($self, $dbh) = (shift, shift);
+
+ my $created_dbh = 0;
+ unless ( ref($dbh) || ! @_ ) {
+ $dbh = DBI->connect( $dbh, @_ ) or die $DBI::errstr;
+ my $gratuitous = $DBI::errstr; #surpress superfluous `used only once' error
+ $created_dbh = 1;
+ }
+ #false laziness: nicked from DBSchema::_load_driver
+ my $driver;
+ if ( ref($dbh) ) {
+ $driver = $dbh->{Driver}->{Name};
+ } else {
+ my $discard = $dbh;
+ $discard =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i #nicked from DBI->connect
+ or '' =~ /()/; # ensure $1 etc are empty if match fails
+ $driver = $1 or die "can't parse data source: $dbh";
+ }
+ #eofalse
+
+#should be in the DBD somehwere :/
+# my $saved_pkey = '';
+# if ( $driver eq 'Pg' && $self->primary_key ) {
+# my $pcolumn = $self->column( (
+# grep { $self->column($_)->name eq $self->primary_key } $self->columns
+# )[0] );
+##AUTO-INCREMENT# $pcolumn->type('serial') if lc($pcolumn->type) eq 'integer';
+# $pcolumn->local( $pcolumn->local. ' PRIMARY KEY' );
+# #my $saved_pkey = $self->primary_key;
+# #$self->primary_key('');
+# #change it back afterwords :/
+# }
+
+ my @columns = map { $self->column($_)->line($dbh) } $self->columns;
+
+ push @columns, "PRIMARY KEY (". $self->primary_key. ")"
+ #if $self->primary_key && $driver ne 'Pg';
+ if $self->primary_key;
+
+ my $indexnum = 1;
+
+ my @r = (
+ "CREATE TABLE ". $self->name. " (\n ". join(",\n ", @columns). "\n)\n"
+ );
+
+ push @r, map {
+ #my($index) = $self->name. "__". $_ . "_idx";
+ #$index =~ s/,\s*/_/g;
+ my $index = $self->name. $indexnum++;
+ "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)\n"
+ } $self->unique->sql_list
+ if $self->unique;
+
+ push @r, map {
+ #my($index) = $self->name. "__". $_ . "_idx";
+ #$index =~ s/,\s*/_/g;
+ my $index = $self->name. $indexnum++;
+ "CREATE INDEX $index ON ". $self->name. " ($_)\n"
+ } $self->index->sql_list
+ if $self->index;
+
+ #$self->primary_key($saved_pkey) if $saved_pkey;
+ $dbh->disconnect if $created_dbh;
+ @r;
+}
+
+#
+
+sub _null_sth {
+ my($dbh, $table) = @_;
+ my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0")
+ or die $dbh->errstr;
+ $sth->execute or die $sth->errstr;
+ $sth;
+}
+
+=back
+
+=head1 AUTHOR
+
+Ivan Kohler <ivan-dbix-dbschema@420.am>
+
+Thanks to Mark Ethan Trostler <mark@zzo.com> for a patch to allow tables
+with no indices.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 BUGS
+
+sql_create_table() has database-specific foo that probably ought to be
+abstracted into the DBIx::DBSchema::DBD:: modules.
+
+sql_create_table may change or destroy the object's data. If you need to use
+the object after sql_create_table, make a copy beforehand.
+
+Some of the logic in new_odbc might be better abstracted into Column.pm etc.
+
+=head1 SEE ALSO
+
+L<DBIx::DBSchema>, L<DBIx::DBSchema::ColGroup::Unique>,
+L<DBIx::DBSchema::ColGroup::Index>, L<DBIx::DBSchema::Column>, L<DBI>
+
+=cut
+
+1;
+
--- /dev/null
+Changes
+MANIFEST
+MANIFEST.SKIP
+README
+TODO
+Makefile.PL
+DBSchema.pm
+t/load.t
+t/load-mysql.t
+t/load-pg.t
+DBSchema/Table.pm
+DBSchema/ColGroup.pm
+DBSchema/ColGroup/Index.pm
+DBSchema/ColGroup/Unique.pm
+DBSchema/Column.pm
+DBSchema/DBD.pm
+DBSchema/DBD/mysql.pm
+DBSchema/DBD/Pg.pm
+DBSchema/DBD/Sybase.pm
--- /dev/null
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'DBIx::DBSchema',
+ 'VERSION_FROM' => 'DBSchema.pm', # finds $VERSION
+ 'PREREQ_PM' => {
+ 'DBI' => 0,
+ 'FreezeThaw' => 0,
+ },
+);
--- /dev/null
+DBIx::DBSchema
+
+Copyright (c) 2000-2002 Ivan Kohler
+Copyright (c) 2000 Mail Abuse Prevention System LLC
+All rights reserved.
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+This module implements an OO-interface to database schemas. Using this module,
+you can create a database schema with an OO Perl interface. You can read the
+schema from an existing database. You can save the schema to disk and restore
+it from different process. Most importantly, DBIx::DBSchema can write SQL
+CREATE statements for different databases from a single source.
+
+Currently supported databases are MySQL, PostgreSQL and Sybase.
+DBIx::DBSchema will attempt to use generic SQL syntax for other databases.
+Assistance adding support for other databases is welcomed. See the
+DBIx::DBSchema::DBD manpage, "Driver Writer's Guide and Base Class".
+
+To install:
+ perl Makefile.PL
+ make
+ make test # nothing substantial yet
+ make install
+
+Documentation will then be available via `man DBIx::DBSchema' or
+`perldoc DBIx::DBSchema'.
+
+Anonymous CVS access is available:
+ $ export CVSROOT=":pserver:anonymous@cleanwhisker.420.am:/home/cvs/cvsroot"
+ $ cvs login
+ (Logging in to anonymous@cleanwhisker.420.am)
+ CVS password: anonymous
+ $ cvs checkout DBIx-DBSchema
+as well as <http://www.420.am/cgi-bin/cvsweb/DBIx-DBSchema>.
+
+A mailing list is available. Send a blank message to
+<ivan-dbix-dbschema-users-subscribe@420.am>.
+
+Homepage: <http://www.420.am/dbix-dbschema>
+
+$Id: README,v 1.1 2004-04-29 09:21:27 ivan Exp $
--- /dev/null
+port and test with additional databases
+
+sql CREATE TABLE output should convert integers
+(i.e. use DBI qw(:sql_types);) to local types using DBI->type_info plus a hash
+to fudge things
+
--- /dev/null
+BEGIN { $| = 1; print "1..1\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use DBIx::DBSchema::DBD::mysql;
+$loaded = 1;
+print "ok 1\n";
--- /dev/null
+print "1..1\n";
+eval "use DBD::Pg 1.32";
+if ( length($@) ) {
+ print "ok 1 # Skipped: DBD::Pg 1.32 required for Pg";
+} else {
+ eval "use DBIx::DBSchema::DBD::Pg;";
+ if ( length($@) ) {
+ print "not ok 1\n";
+ } else {
+ print "ok 1\n";
+ }
+}
--- /dev/null
+BEGIN { $| = 1; print "1..1\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use DBIx::DBSchema;
+$loaded = 1;
+print "ok 1\n";
# BEGIN LICENSE BLOCK
#
-# Copyright (c) 1996-2002 Jesse Vincent <jesse@bestpractical.com>
+# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
#
# (Except where explictly superceded by other copyright notices)
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
-# from www.gnu.org
+# from www.gnu.org.
#
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-#
# Unless otherwise specified, all modifications, corrections or
# extensions to this work which alter its source code become the
# property of Best Practical Solutions, LLC when submitted for
#
#
# END LICENSE BLOCK
-
-
#
# DO NOT HAND-EDIT the file named 'Makefile'. This file is autogenerated.
# Have a look at "configure" and "Makefile.in" instead
RT_VERSION_MAJOR = 3
RT_VERSION_MINOR = 0
-RT_VERSION_PATCH = 4
+RT_VERSION_PATCH = 9
RT_VERSION = $(RT_VERSION_MAJOR).$(RT_VERSION_MINOR).$(RT_VERSION_PATCH)
TAG = rt-$(RT_VERSION_MAJOR)-$(RT_VERSION_MINOR)-$(RT_VERSION_PATCH)
RT_FASTCGI_HANDLER = $(RT_BIN_PATH)/mason_handler.fcgi
# RT_WIN32_FASTCGI_HANDLER is the mason handler script for FastCGI
RT_WIN32_FASTCGI_HANDLER = $(RT_BIN_PATH)/mason_handler.svc
-# RT's admin CLI
-RT_CLI_ADMIN_BIN = $(RT_BIN_PATH)/rtadmin
+# RT's CLI
+RT_CLI_BIN = $(RT_BIN_PATH)/rt
# RT's mail gateway
RT_MAILGATE_BIN = $(RT_BIN_PATH)/rt-mailgate
# RT's cron tool
BINARIES = $(DESTDIR)/$(RT_MODPERL_HANDLER) \
$(DESTDIR)/$(RT_MAILGATE_BIN) \
+ $(DESTDIR)/$(RT_CLI_BIN) \
$(DESTDIR)/$(RT_CRON_BIN) \
$(SETGID_BINARIES)
SYSTEM_BINARIES = $(DESTDIR)/$(RT_SBIN_PATH)/
# DB_TYPE defines what sort of database RT trys to talk to
# "mysql" is known to work.
# "Pg" is known to work
+# "Informix" is known to work
DB_TYPE = mysql
# For mysql, you probably want 'root'
# For Pg, you probably want 'postgres'
-# For oracle, you want 'system'
+# For Oracle, you want 'system'
+# For Informix, you want 'informix'
DB_DBA = root
@echo " $(RT_SBIN_PATH)/rt-setup-database --action insert --datafile etc/upgrade/<version>"
-upgrade: dirs upgrade-noclobber upgrade-instruct
+upgrade: config-install dirs files-install fixperms upgrade-instruct
upgrade-noclobber: config-install libs-install html-install bin-install local-install doc-install fixperms
test:
$(PERL) -Ilib lib/t/00smoke.t
-regression-nosetgid-quiet: config-install dirs files-install libs-install sbin-install bin-install regression-instruct regression-reset-db testify-pods fixperms-nosetgid apachectl
+regression-install: config-install
+ $(PERL) -pi -e 's/Set\(\$$DatabaseName.*\);/Set\(\$$DatabaseName, "rt3regression"\);/' $(DESTDIR)/$(CONFIG_FILE)
+
+regression-nosetgid-quiet: regression-install dirs files-install libs-install sbin-install bin-install regression-instruct regression-reset-db testify-pods fixperms-nosetgid apachectl
$(PERL) sbin/regression_harness
-regression-nosetgid: config-install dirs files-install libs-install sbin-install bin-install regression-instruct regression-reset-db testify-pods fixperms-nosetgid apachectl
+regression-nosetgid: regression-install dirs files-install libs-install sbin-install bin-install regression-instruct regression-reset-db testify-pods fixperms-nosetgid apachectl
$(PERL) lib/t/02regression.t
-regression: config-install dirs files-install libs-install sbin-install bin-install regression-instruct regression-reset-db testify-pods apachectl
+regression: regression-install dirs files-install libs-install sbin-install bin-install regression-instruct regression-reset-db testify-pods fixperms apachectl
$(PERL) lib/t/02regression.t
regression-quiet:
-cp -rp \
bin/rt-mailgate \
bin/mason_handler.fcgi \
+ bin/mason_handler.scgi \
bin/mason_handler.svc \
+ bin/rt \
bin/webmux.pl \
bin/rt-crontool \
$(DESTDIR)/$(RT_BIN_PATH)
-# BEGIN LICENSE BLOCK
-#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
-#
-# (Except where explictly superceded by other copyright notices)
-#
-# This work is made available to you under the terms of Version 2 of
-# the GNU General Public License. A copy of that license should have
-# been provided with this software, but in any event can be snarfed
-# from www.gnu.org.
-#
-# This work is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
-#
-#
-# END LICENSE BLOCK
-RT is an enterprise-grade issue tracking system. It allows
-organizations to keep track of their to-do lists, who is working
-on which tasks, what's already been done, and when tasks were
-completed. It is available under the terms of version 2 of the GNU
-General Public License (GPL), so it doesn't cost anything to set
-up and use.
+RT is an enterprise-grade issue tracking system. It allows organizations
+to keep track of what needs to get done, who is working on which tasks,
+what's already been done, and when tasks were (or weren't) completed.
+RT doesn't cost anything to use, no matter how much you use it; it
+is freely available under the terms of Version 2 of the GNU General
+Public License.
+
+RT is commercially-supported software. To purchase support, training,
+custom development, or professional services, please get in touch with
+us at sales@bestpractical.com.
+
+ Jesse Vincent
+ Best Practical Solutions, LLC
+ March, 2005
- Jesse Vincent
- Best Practical Solutions, LLC
- March 2003
REQUIRED PACKAGES:
------------------
-o Perl 5.8.0 or later (http://www.perl.com).
+o Perl 5.8.3 or later (http://www.perl.com).
- (If you intend to use the FastCGI or SpeedyCGI support, you
- need to make sure that perl has been built with support for
- setgid perl scripts.)`
+ Perl versions prior to 5.8.3 contain bugs that could result
+ in data corruption. We recommend strongly that you use 5.8.3
+ or newer.
- Perl 5.6.1 is currently deprecated and will be officially desupported
- in a future release
+o A supported SQL database
-o A DB backend; MySQL is recommended ( http://www.mysql.com )
- Currently supported: Mysql 4.0.13 or later.
+ Currently supported: Mysql 4.0.13 or later with InnoDB support.
Postgres 7.2 or later.
-
- Mysql 3.23.46 or newer with support for InnoDB
- is currently deprecated and will be officially
- desupported in a future release.
+ Oracle 9iR2 or later.
+ SQLite 3.0. (Not recommended for production)
o Apache version 1.3.x or 2.x (http://httpd.apache.org)
- with mod_perl -- (http://perl.apache.org )
- or a webserver with FastCGI support (www.fastcgi.com)
-
- mod_perl 2.0 isn't quite ready for prime_time just yet;
- Best Practical Solutions strongly recommends that sites use
- Apache 1.3 or FastCGI.
+ with mod_perl -- (http://perl.apache.org )
+ or a webserver with FastCGI support (www.fastcgi.com)
Compiling mod_perl on Apache 1.3.x as a DSO has been known
- to have massive stability problems and is not recommended.
-
- mod_perl 1.x must be build with EVERYTHING=1
-
- RT's FastCGI handler runs setgid to the 'rt' group to
- protect RT's database password. You may need to install
- a special "suidperl" package or reconfigure your perl
- setup to support "setuid scripts" if you intend to use RT
- with FastCGI.
-
- Debian GNU/* 3.0+: the package which installs suidperl is
- called perl-suid, and should work without any tweaking.
-
- FreeBSD 4.2+: the package is called sperl, and should
- install a suidperl that just works
-
- Conectiva Linux 6.0+: suidperl is installed by default when
- perl is installed, but the program /bin/suidperl is not setuid.
- You must use chmod to make it setuid.
+ to have massive stability problems and is not recommended.
+ mod_perl 1.x must be built with EVERYTHING=1
+ RT's FastCGI handler needs to access RT's configuration file.
o Various and sundry perl modules
A tool included with RT takes care of the installation of
The tool supplied with RT uses Perl's CPAN system
(http://www.cpan.org) to install modules. Some operating
- systems package all or some of the modules required and
+ systems package all or some of the modules required, and
you may be better off installing the modules that way.
GENERAL INSTALLATION
--------------------
-This is a rough guide to installing RT. For more detail, you'll want
-to read 'Chapter 2: Installing' in RT's manual, available at
-http://www.bestpractical.com/rt
+This is a rough guide to installing RT. For more detail, you'll
+want to read a more comprehensive installation guide at:
-1 Unpack this distribution SOMWHERE OTHER THAN where you want to install RT
+ http://wiki.bestpractical.com/index.cgi?InstallationGuides
- Granted, you've already got it open. To do this cleanly:
+1 Unpack this distribution other than where you want to install RT
- tar xzvf rt.tar.gz -C /tmp
+ To do this cleanly, run the following command:
+
+ tar xzvf rt.tar.gz -C /tmp
2 Run the "configure" script.
- ./configure --help to see the list of options
- ./configure (with the flags you want)
+ ./configure --help to see the list of options
+ ./configure (with the flags you want)
+
+ RT defaults to installing in /opt/rt3 with MySQL as its database. It
+ tries to guess which of www-data, www, apache or nobody your webserver
+ will run as, but you can override that behavior.
+
+3 Make sure that RT has everything it needs to run.
+
+ Check for missing dependencies by running:
+
+ make testdeps
+
+4 If the script reports any missing dependencies, install them by hand
+ or run the following command as a user who has permission to install perl
+ modules on your system:
+
+ make fixdeps
+
+5 Check to make sure everything was installed properly.
+
+ make testdeps
+
+ It might sometimes be necessary to run "make fixdeps" several times
+ to install all necessary perl modules.
+
+6 If this is a new installation:
+
+ As a user with permission to install RT in your chosen directory, type:
+
+ make install
+
+ Set up etc/RT_SiteConfig.pm in your RT installation directory.
+ You'll need to add any values you need to change from the defaults
+ in etc/RT_Config.pm
+
+ As a user with permission to read RT's configuration file, type:
+
+ make initialize-database
-3 Satisfy RT's myriad dependencies.
+ If the make fails, type:
+
+ make dropdb
-3.1 Check for compliance:
-
- perl sbin/rt-test-dependencies \
- --with-<databasename> --with-<web-environment>
+ and start over from step 6
- databasename is one of: mysql, postgres
- web-environment is one of: fastcgi, modperl1, modperl2
+7 If you're upgrading from RT 3.0 or newer:
-3.2 If there are unsatisfied dependencies, install them by hand or run:
+ Read through the UPGRADING document included in this distribution.
+
+ It includes special upgrade instructions that will help you get this
+ new version of RT up and running smoothly.
- perl sbin/rt-test-dependencies \
- --with-<databasename> --with-<web-environment> --install
-
+ As a user with permission to install RT in your chosen installation
+ directory, type:
-3.3 Check to make sure everything was installed properly:
+ make upgrade
- perl sbin/rt-test-dependencies \
- --with-<databasename> --with-<web-environment>
+ This will install new binaries, config files and libraries without
+ overwriting your RT database.
-4 Create a group called 'rt'
+ Update etc/RT_SiteConfig.pm in your RT installation directory.
+ You'll need to add any new values you need to change from the defaults
+ in etc/RT_Config.pm
-5a FOR A NEW INSTALLATION:
-
- As root, type:
- make install (replace "make" with the local name for
- Make, if you need to)
+ You may also need to update RT's database. To find out, type:
-
- make initialize-database
+ ls etc/upgrade
+ For each item in that directory whose name is greater than
+ your previously installed RT version, run:
- If the make fails, type:
- make dropdb
- and start over from step 5a
+ /opt/rt3/sbin/rt-setup-database --action schema \
+ --datadir etc/upgrade/<version>
+ /opt/rt3/sbin/rt-setup-database --action acl \
+ --datadir etc/upgrade/<version>
+ /opt/rt3/sbin/rt-setup-database --action insert \
+ --datadir etc/upgrade/<version>
-5b FOR UPGRADING: (Within the RT 3.0.x series)
+ Clear mason cache dir:
- As root, type:
- make upgrade (replace "make" with the local name for
- Make, if you need to)
+ rm -fr /opt/rt3/var/mason_data/obj
- This will build new binaries, config files and libraries without
- overwriting your RT database.
-
- It may then instruct you to update your RT system database objects
+ Stop and start web-server.
-6 Edit etc/RT_SiteConfig.pm in your RT installation directory, by specifying
- any values you need to change from the defaults in etc/RT_Config.pm
-7 Configure the email and web gateways, as described below.
+8 If you're upgrading from RT 2.0:
-8 Stop and start your webserver, so it picks up your configuration changes.
+ Please upgrade from RT 2.0 to RT 3.2 and then follow the instructions
+ for section 7.
+
+9 Configure the email and web gateways, as described below.
NOTE: root's password for the web interface is "password"
- (without the quotes.) Not changing this is a SECURITY risk
+ (without the quotes). Not changing this is a SECURITY risk!
-9 Configure RT per the instructions in RT's manual.
+10 Set up users, groups, queues, scrips and access control.
Until you do this, RT will not be able to send or receive email,
nor will it be more than marginally functional. This is not an
optional step.
-THE WEB INTERFACE
------------------
+SETTING UP THE WEB INTERFACE
+----------------------------
+
+RT's web interface is based around HTML::Mason, which works well with
+the mod_perl perl interpreter within Apache httpd and FastCGI
+
+mod_perl
+--------
-RT's web interface is based around HTML::Mason, which works best with the mod_perl
-perl interpreter within Apache httpd. Alternatively, support for the FastCGI
-(and plain CGI) interface is also provided as 'bin/mason_handler.fcgi'.
+To install RT with mod_perl, you'll need to install the
+apache database connection cache. To make sure it's installed, run
+the following command:
-Apache
- You'll need to add a few lines to your httpd.conf telling it about RT:
+ perl -MCPAN -e'install Apache::DBI'
+
+Next, add a few lines to your Apache configuration file, so that
+it knows where to find RT:
<VirtualHost your.ip.address>
ServerName your.rt.server.hostname
DocumentRoot /opt/rt3/share/html
AddDefaultCharset UTF-8
- # this line applies to Apache2+mod_perl2 only
- PerlModule Apache2 Apache::compat
-
PerlModule Apache::DBI
PerlRequire /opt/rt3/bin/webmux.pl
- # this section applies to Apache 1 only
<Location />
- SetHandler perl-script
- PerlHandler RT::Mason
+ SetHandler perl-script
+ PerlHandler RT::Mason
</Location>
+</VirtualHost>
+
+FastCGI
+-------
+
+Installation with FastCGI is a little bit more complex and is documented
+in detail at http://wiki.bestpractical.com/index.cgi?FastCGIConfiguration
+
+In the most basic configuration, you can set up your webserver to run
+as a user who is a member of the "rt" unix group so that the FastCGI script
+can read RT's configuration file. It's important to understand the security
+implications of this configuration, which are discussed in the document
+mentioned above.
+
+To install RT with FastCGI, you'll need to add a few lines to your
+Apache configuration file telling it about RT:
+
+<VirtualHost rt.example.com>
- # this section applies to Apache2+mod_perl2 only
- <FilesMatch "\.html$">
- SetHandler perl-script
- PerlHandler RT::Mason
- </FilesMatch>
- <LocationMatch "/Attachment/">
- SetHandler perl-script
- PerlHandler RT::Mason
- </LocationMatch>
- <LocationMatch "/REST/">
- SetHandler perl-script
- PerlHandler RT::Mason
- </LocationMatch>
+ # Pass through requests to display images
+ Alias /NoAuth/images/ /opt/rt3/share/html/NoAuth/images/
+
+ # Tell FastCGI to put its temporary files somewhere sane.
+ FastCgiIpcDir /tmp
+
+ FastCgiServer /opt/rt3/bin/mason_handler.fcgi -idle-timeout 120
+
+ AddHandler fastcgi-script fcgi
+ ScriptAlias / /opt/rt3/bin/mason_handler.fcgi/
+
</VirtualHost>
SETTING UP THE MAIL GATEWAY
---------------------------
-An alias for the initial queue will need to be made in either your
-global mail aliases file (if you are using NIS) or locally on your
-machine.
-
-Add the following lines to /etc/aliases (or your local equivalent) :
+To let email flow to your RT server, you need to add a few lines of
+configuration to your mail server's "aliases" file. These lines "pipe"
+incoming email messages from your mail server to RT.
-rt: "|/opt/rt3/bin/rt-mailgate --queue general --action correspond --url http://localhost/"
-rt-comment: "|/opt/rt3/bin/rt-mailgate --queue general --action comment --url http://localhost/"
- | | |
- <queue-name>----/ | |
- | |
- <correspond or comment depending on whether | |
- the mail should be resent to the requestor>---/ |
- |
- <URL for RT's web interface>---/
+Add the following lines to /etc/aliases (or your local equivalent) on your mail server:
+rt: "|/opt/rt3/bin/rt-mailgate --queue general --action correspond --url http://rt.example.com/"
+rt-comment: "|/opt/rt3/bin/rt-mailgate --queue general --action comment --url http://rt.example.com/"
+
+You'll need to add similar lines for each queue you want to be able
+to send email to. To find out more about how to configure RT's email
+gateway, type:
+
+ perldoc /opt/rt3/bin/rt-mailgate
-BUGS
-----
-To report a bug, send email to rt-3.0-bugs@fsck.com.
GETTING HELP
------------
If RT is mission-critical for you or if you use it heavily, we recommend that
you purchase a commercial support contract. Details on support contracts
-are available at http://www.bestpractical.com.
+are available at http://www.bestpractical.com or by writing to
+<sales@bestpractical.com>.
If you're interested in having RT extended or customized or would like more
information about commercial support options, please send email to
<sales@bestpractical.com> to discuss rates and availability.
-RT-USERS MAILINGLIST
+
+RT WEBSITE
+----------
+
+For current information about RT, check out the RT website at
+ http://www.bestpractical.com/
+
+You'll find screenshots, a pointer to the current version of RT, contributed
+patches, and lots of other great stuff.
+
+
+
+RT-USERS MAILING LIST
--------------------
To keep up to date on the latest RT tips, techniques and extensions,
you probably want to join the rt-users mailing list. Send a message to:
- rt-users-request@lists.fsck.com
+ rt-users-request@lists.bestpractical.com
-With the body of the message consisting of only the word:
+with the body of the message consisting of only the word:
- subscribe
+ subscribe
If you're interested in hacking on RT, you'll want to subscribe to
-rt-devel@lists.fsck.com. Subscribe to it with instructions similar to
-those above.
+rt-devel@lists.bestpractical.com. Subscribe to it with instructions
+similar to those above.
Address questions about the stable release to the rt-users list, and
questions about the development version to the rt-devel list. If you feel
<jesse@bestpractical.com>.
-RT WEBSITE
-----------
-
-For current information about RT, check out the RT website at
- http://www.bestpractical.com/
-
-You'll find screenshots, a pointer to the current version of RT, contributed
-patches, and lots of other great stuff.
+BUGS
+----
-TROUBLESHOOTING
----------------
+RT's a pretty complex application, and as you get up to speed, you might
+run into some trouble. Generally, it's best to ask about things you
+run into on the rt-users mailinglist (or pick up a commercial support
+contract from Best Practical). But, sometimes people do run into bugs. In
+the exceedingly unlikely event that you hit a bug in RT, please report
+it! We'd love to hear about problems you have with RT, so we can fix them.
+To report a bug, send email to rt-bugs@fsck.com.
-If the solution to the problem you're running into isn't obvious and you've
-checked the FAQ, feel free to send mail to rt-users@fsck.com (for released
-versions of RT) or rt-devel@fsck.com (for development versions).
-Thanks!
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
use File::Basename;
require ('/opt/rt3/bin/webmux.pl');
-my $h = &RT::Interface::Web::NewCGIHandler();
+my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters);
# Enter CGI::Fast mode, which should also work as a vanilla CGI script.
require CGI::Fast;
$ENV{'ENV'} = '' if defined $ENV{'ENV'};
$ENV{'IFS'} = '' if defined $ENV{'IFS'};
- unless ($h->interp->comp_exists($cgi->path_info)) {
- $cgi->path_info($cgi->path_info . "/index.html");
+ RT::ConnectToDatabase();
+
+ if ( ( !$h->interp->comp_exists( $cgi->path_info ) )
+ && ( $h->interp->comp_exists( $cgi->path_info . "/index.html" ) ) ) {
+ $cgi->path_info( $cgi->path_info . "/index.html" );
+ }
+
+ eval { $h->handle_cgi_object($cgi); };
+ if ($@) {
+ $RT::Logger->crit($@);
+ }
+
+
+ if ($RT::Handle->TransactionDepth) {
+ $RT::Handle->ForceRollback;
+ $RT::Logger->crit("Transaction not committed. Usually indicates a software fault. Data loss may have occurred") ;
}
- $h->handle_cgi_object($cgi);
- # _should_ always be tied
+
+
}
1;
use strict;
require ('/opt/rt3/bin/webmux.pl');
-my $h = &RT::Interface::Web::NewCGIHandler();
+my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters);
require CGI;
RT::Init();
my $cgi = CGI->new;
-unless ($h->interp->comp_exists($cgi->path_info)) {
- $cgi->path_info($cgi->path_info . "/index.html");
+if ( ( !$h->interp->comp_exists( $cgi->path_info ) )
+ && ( $h->interp->comp_exists( $cgi->path_info . "/index.html" ) ) ) {
+ $cgi->path_info( $cgi->path_info . "/index.html" );
}
+
$h->handle_cgi_object($cgi);
1;
#!/usr/bin/perl -w
# BEGIN LICENSE BLOCK
-#
+#
# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
-#
+#
# (Except where explictly superceded by other copyright notices)
-#
+#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# been provided with this software, but in any event can be snarfed
# from www.gnu.org.
-#
+#
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
-#
+#
# Unless otherwise specified, all modifications, corrections or
# extensions to this work which alter its source code become the
# property of Best Practical Solutions, LLC when submitted for
# inclusion in the work.
-#
-#
+#
+#
# END LICENSE BLOCK
=head1 NAME
use RT::I18N;
+# Make sure that when we call the mailgate wrong, it tempfails
+
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://bad.address"), "Opened the mailgate - The error below is expected - $@");
+print MAIL <<EOF;
+From: root\@localhost
+To: rt\@example.com
+Subject: This is a test of new ticket creation
+
+Foob!
+EOF
+close (MAIL);
+
+# Check the return value
+is ( $? >> 8, 75, "The error message above is expected The mail gateway exited with a failure. yay");
+
# {{{ Test new ticket creation by root who is privileged and superuser
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: root\@localhost
To: rt\@example.com
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
+
use RT::Tickets;
my $tickets = RT::Tickets->new($RT::SystemUser);
$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
# {{{This is a test of new ticket creation as an unknown user
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: doesnotexist\@example.com
To: rt\@example.com
Foob!
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
$tickets = RT::Tickets->new($RT::SystemUser);
$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
sleep(60); # gotta sleep so the remote process' ACL cache times out
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: doesnotexist\@example.com
To: rt\@example.com
Foob!
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
$tickets = RT::Tickets->new($RT::SystemUser);
#ok ($val, "Granted everybody the right to create tickets - $msg");
#sleep(60); # gotta sleep so the remote process' ACL cache times out
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: doesnotexist-2\@example.com
To: rt\@example.com
Foob!
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
$u = RT::User->new($RT::SystemUser);
$u->Load('doesnotexist-2@example.com');
ok ($val, "Granted everybody the right to reply to tickets - $msg");
sleep(60); # gotta sleep so the remote process' ACL cache times out
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: doesnotexist-2\@example.com
To: rt\@example.com
Foob!
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
$u = RT::User->new($RT::SystemUser);
#ok ($val, "Granted everybody the right to create tickets - $msg");
#sleep(60); # gotta sleep so the remote process' ACL cache times out
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action comment"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action comment"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: doesnotexist-3\@example.com
To: rt\@example.com
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
+
$u = RT::User->new($RT::SystemUser);
$u->Load('doesnotexist-3@example.com');
ok( $u->Id == 0, " user does not exist and was not created by ticket comment submission");
ok ($val, "Granted everybody the right to reply to tickets - $msg");
sleep(60); # gotta sleep so the remote process' ACL cache times out
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action comment"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action comment"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: doesnotexist-3\@example.com
To: rt\@example.com
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
$u = RT::User->new($RT::SystemUser);
$u->Load('doesnotexist-3@example.com');
Data => ['This is a test of a binary attachment']);
# currently in lib/t/autogen
-$entity->attach(Path => '../../../html/NoAuth/images/spacer.gif',
+$entity->attach(Path => '/opt/rt3/share/html/NoAuth/images/spacer.gif',
Type => 'image/gif',
Encoding => 'base64');
# Create a ticket with a binary attachment
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
$entity->print(\*MAIL);
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
+
my $tickets = RT::Tickets->new($RT::SystemUser);
$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
$tickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0');
# Grab the binary attachment via the web ui
my $ua = LWP::UserAgent->new();
-my $full_url = "http://localhost/Ticket/Attachment/".$attachment->TransactionId."/".$attachment->id."/spacer.gif?&user=root&pass=password";
+my $full_url = "http://localhost".$RT::WebPath."/Ticket/Attachment/".$attachment->TransactionId."/".$attachment->id."/spacer.gif?&user=root&pass=password";
my $r = $ua->get( $full_url);
# {{{ Simple I18N testing
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: root\@localhost
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
+
my $unitickets = RT::Tickets->new($RT::SystemUser);
$unitickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
$unitickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0');
ok($unitick->Transactions->First->Attachments->First->Content =~ /$unistring/i, $unitick->Id." appears to be unicode ". $unitick->Transactions->First->Attachments->First->Id);
# supposedly I18N fails on the second message sent in.
-ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost/ --queue general --action correspond"), "Opened the mailgate - $@");
+ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@");
print MAIL <<EOF;
From: root\@localhost
EOF
close (MAIL);
+#Check the return value
+is ($? >> 8, 0, "The mail gateway exited normally. yay");
+
my $tickets2 = RT::Tickets->new($RT::SystemUser);
$tickets2->OrderBy(FIELD => 'id', ORDER => 'DESC');
$tickets2->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0');
use constant EX_TEMPFAIL => 75;
my %opts;
-GetOptions( \%opts, "queue=s", "action=s", "url=s", "jar=s", "help", "debug", "extension=s" );
+GetOptions( \%opts, "queue=s", "action=s", "url=s", "jar=s", "help", "debug", "extension=s", "timeout=i" );
if ( $opts{help} ) {
require Pod::Usage;
}
undef $/;
-my $message = <>;
my $ua = LWP::UserAgent->new();
$ua->cookie_jar( { file => $opts{jar} } );
my %args = (
queue => $opts{queue},
action => $opts{action},
- message => $message,
SessionType => 'REST', # Surpress login box
);
+# Read the message in from STDIN
+$args{'message'} = <>;
+
if ($opts{'extension'}) {
$args{$opts{'extension'}} = $ENV{'EXTENSION'};
+$ua->timeout(exists($opts{'timeout'}) ? $opts{'timeout'} : 180);
my $r = $ua->post( $full_url, {%args} );
check_failure($r);
# It's not the server's fault if the mail is bogus. We just want to know that
# *something* came out of the server.
- die <<EOF
+ warn <<EOF;
RT server error.
The RT server which handled your email did not behave as expected. It
$content
EOF
+exit EX_TEMPFAIL;
+
}
+exit;
+
+
sub check_failure {
my $r = shift;
return if $r->is_success();
rt-mailgate --action (correspond|comment) --queue queuename
--url http://your.rt.server/
- [ --extension (queue|action|ticket)
+ [ --debug ]
+ [ --extension (queue|action|ticket) ]
+ [ --timeout seconds ]
+
+
See C<man rt-mailgate> for more.
is related to. "action" will allow the user to specify either "comment" or
"correspond" in the address extension.
+=item C<--debug> OPTIONAL
+
+Print debugging output to standard error
+
+
+=item C<--timeout> OPTIONAL
+
+Configure the timeout for posting the message to the web server. The
+default timeout is 3 minutes (180 seconds).
+
=head1 DESCRIPTION
+++ /dev/null
-#!/usr/bin/perl
-# BEGIN LICENSE BLOCK
-#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
-#
-# (Except where explictly superceded by other copyright notices)
-#
-# This work is made available to you under the terms of Version 2 of
-# the GNU General Public License. A copy of that license should have
-# been provided with this software, but in any event can be snarfed
-# from www.gnu.org.
-#
-# This work is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
-#
-#
-# END LICENSE BLOCK
-
-use strict;
-
-BEGIN {
- $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need
- $ENV{'CDPATH'} = '' if defined $ENV{'CDPATH'};
- $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
- $ENV{'ENV'} = '' if defined $ENV{'ENV'};
- $ENV{'IFS'} = '' if defined $ENV{'IFS'};
-}
-
-use lib ("/opt/rt3/local/lib", "/opt/rt3/lib");
-use RT;
-
-package RT::Mason;
-
-use CGI qw(-private_tempfiles); #bring this in before mason, to make sure we
- #set private_tempfiles
-
-BEGIN {
- if ($CGI::MOD_PERL) {
- require HTML::Mason::ApacheHandler;
- }
- else {
- require HTML::Mason::CGIHandler;
- }
-}
-
-use HTML::Mason; # brings in subpackages: Parser, Interp, etc.
-
-use vars qw($Nobody $SystemUser $r);
-
-#This drags in RT's config.pm
-RT::LoadConfig();
-
-use Carp;
-
-{
- package HTML::Mason::Commands;
- use vars qw(%session);
-
- use RT::Tickets;
- use RT::Transactions;
- use RT::Users;
- use RT::CurrentUser;
- use RT::Templates;
- use RT::Queues;
- use RT::ScripActions;
- use RT::ScripConditions;
- use RT::Scrips;
- use RT::Groups;
- use RT::GroupMembers;
- use RT::CustomFields;
- use RT::CustomFieldValues;
- use RT::TicketCustomFieldValues;
-
- use RT::Interface::Web;
- use MIME::Entity;
- use Text::Wrapper;
- use CGI::Cookie;
- use Time::ParseDate;
- use HTML::Entities;
-}
-
-
-# Activate the following if running httpd as root (the normal case).
-# Resets ownership of all files created by Mason at startup.
-# Note that mysql uses DB for sessions, so there's no need to do this.
-unless ($RT::DatabaseType =~ /(mysql|Pg)/) {
- # Clean up our umask to protect session files
- umask(0077);
-
-if ( $CGI::MOD_PERL) {
- chown( Apache->server->uid, Apache->server->gid, [$RT::MasonSessionDir] )
- if Apache->server->can('uid');
- }
- # Die if WebSessionDir doesn't exist or we can't write to it
- stat($RT::MasonSessionDir);
- die "Can't read and write $RT::MasonSessionDir"
- unless ( ( -d _ ) and ( -r _ ) and ( -w _ ) );
-}
-
-my $ah = &RT::Interface::Web::NewApacheHandler() if $CGI::MOD_PERL;
-
-sub handler {
- ($r) = @_;
-
- RT::Init();
-
- # We don't need to handle non-text items
- return -1 if defined( $r->content_type ) && $r->content_type !~ m|^text/|io;
-
- my %session;
- my $status = $ah->handle_request($r);
- undef (%session);
-
- $RT::Logger->crit("Transaction not committed. Usually indicates a software fault. Data loss may have occurred") if $RT::Handle->TransactionDepth;
- return $status;
-}
-
-1;
--- /dev/null
+(test "x$prefix" = "xNONE" || test "x$prefix" = "x") && prefix=/opt/rt3
+(test "x$exec_prefix" = "xNONE" || test "x$exec_prefix" = "x") && exec_prefix=${prefix}
+bindir=${exec_prefix}/bin
+sbindir=${exec_prefix}/sbin
+sysconfdir=${prefix}/etc
+mandir=${prefix}/man
+libdir=${prefix}/lib
+datadir=${prefix}/share
+(test "x$htmldir" = "xNONE" || test "x$htmldir" = "x") && htmldir=${datadir}/html
+(test "x$manualdir" = "xNONE" || test "x$manualdir" = "x") && manualdir=${datadir}/doc
+localstatedir=${prefix}/var
+(test "x$logfiledir" = "xNONE" || test "x$logfiledir" = "x") && logfiledir=${localstatedir}/log
+(test "x$masonstatedir" = "xNONE" || test "x$masonstatedir" = "x") && masonstatedir=${localstatedir}/mason_data
+(test "x$sessionstatedir" = "xNONE" || test "x$sessionstatedir" = "x") && sessionstatedir=${localstatedir}/session_data
+(test "x$customdir" = "xNONE" || test "x$customdir" = "x") && customdir=${prefix}/local
+(test "x$custometcdir" = "xNONE" || test "x$custometcdir" = "x") && custometcdir=${customdir}/etc
+(test "x$customhtmldir" = "xNONE" || test "x$customhtmldir" = "x") && customhtmldir=${customdir}/html
+(test "x$customlexdir" = "xNONE" || test "x$customlexdir" = "x") && customlexdir=${customdir}/po
+(test "x$customlibdir" = "xNONE" || test "x$customlibdir" = "x") && customlibdir=${customdir}/lib
sub acl {
return (
-"CREATE USER ${RT::DatabaseUser} identified by ${RT::DatabasePassword}".
-"temporary tablespace TEMP" .
-"default tablespace USERS" .
-"quota unlimited on USERS;" ,
-"grant connect, resource to ${RT::DatabaseUser};",
-"exit;");
+"CREATE USER ${RT::DatabaseUser} identified by ${RT::DatabasePassword} ".
+"default tablespace USERS " .
+"temporary tablespace TEMP " .
+"quota unlimited on USERS" ,
+"grant connect, resource to ${RT::DatabaseUser}"
+);
}
1;
attachments_id_seq
Attachments
+ Attributes
+ attributes_id_seq
queues_id_seq
- Queues
+ Queues
links_id_seq
- Links
+ Links
principals_id_seq
- Principals
+ Principals
groups_id_seq
- Groups
+ Groups
scripconditions_id_seq
- ScripConditions
+ ScripConditions
transactions_id_seq
- Transactions
+ Transactions
scrips_id_seq
- Scrips
+ Scrips
acl_id_seq
- ACL
+ ACL
groupmembers_id_seq
- GroupMembers
+ GroupMembers
cachedgroupmembers_id_seq
- CachedGroupMembers
+ CachedGroupMembers
users_id_seq
- Users
+ Users
tickets_id_seq
- Tickets
+ Tickets
scripactions_id_seq
- ScripActions
+ ScripActions
templates_id_seq
- Templates
- ticketcustomfieldvalues_id_s
- TicketCustomFieldValues
+ Templates
+ objectcustomfieldvalues_id_s
+ ObjectCustomFieldValues
customfields_id_seq
- CustomFields
+ CustomFields
+ objectcustomfields_id_s
+ ObjectCustomFields
customfieldvalues_id_seq
CustomFieldValues
sessions
sub acl {
+return () if !$RT::DatabaseUser or $RT::DatabaseUser eq 'root';
return (
"USE mysql;",
"DELETE FROM user WHERE user = '${RT::DatabaseUser}';",
"DELETE FROM db where db = '${RT::DatabaseName}';",
-"GRANT SELECT,INSERT,CREATE,INDEX,UPDATE,DELETE ON ${RT::DatabaseName}.* TO ${RT::DatabaseUser}\@${RT::DatabaseRTHost} IDENTIFIED BY '${RT::DatabasePassword}';");
+"GRANT SELECT,INSERT,CREATE,INDEX,UPDATE,DELETE ON ${RT::DatabaseName}.* TO ${RT::DatabaseUser}\@'${RT::DatabaseRTHost}' IDENTIFIED BY '${RT::DatabasePassword}';");
}
1;
PRIMARY KEY (id)
) TYPE=InnoDB;
-CREATE INDEX Attachments1 ON Attachments (Parent) ;
CREATE INDEX Attachments2 ON Attachments (TransactionId) ;
CREATE INDEX Attachments3 ON Attachments (Parent, TransactionId) ;
# }}}
CREATE UNIQUE INDEX Links1 ON Links (Base, Target, Type) ;
CREATE INDEX Links2 ON Links (Base, Type) ;
CREATE INDEX Links3 ON Links (Target, Type) ;
+CREATE INDEX Links4 ON Links (Type,LocalBase);
# }}}
Description varchar(255) NULL ,
Domain varchar(64),
Type varchar(64),
- Instance varchar(64),
+ Instance integer,
PRIMARY KEY (id)
) TYPE=InnoDB;
CREATE INDEX Groups1 ON Groups (Domain,Instance,Type,id);
-CREATE INDEX Groups2 On Groups (Type, Instance, Domain);
+CREATE INDEX Groups2 On Groups (Type, Instance);
# }}}
# {{{ Transactions
CREATE TABLE Transactions (
id INTEGER NOT NULL AUTO_INCREMENT,
- EffectiveTicket integer NOT NULL DEFAULT 0 ,
- Ticket integer NOT NULL DEFAULT 0 ,
+ ObjectType varchar(64) NOT NULL,
+ ObjectId integer NOT NULL DEFAULT 0 ,
TimeTaken integer NOT NULL DEFAULT 0 ,
Type varchar(20) NULL ,
Field varchar(40) NULL ,
OldValue varchar(255) NULL ,
NewValue varchar(255) NULL ,
- Data varchar(100) NULL ,
+ ReferenceType varchar(255) NULL,
+ OldReference integer NULL ,
+ NewReference integer NULL ,
+ Data varchar(255) NULL ,
Creator integer NOT NULL DEFAULT 0 ,
Created DATETIME NULL ,
PRIMARY KEY (id)
) TYPE=InnoDB;
-CREATE INDEX Transactions1 ON Transactions (Ticket);
-CREATE INDEX Transactions2 ON Transactions (EffectiveTicket);
+CREATE INDEX Transactions1 ON Transactions (ObjectType, ObjectId);
# }}}
) TYPE=InnoDB;
CREATE INDEX DisGrouMem on CachedGroupMembers (GroupId,MemberId,Disabled);
-CREATE INDEX GrouMem on CachedGroupMembers (GroupId,MemberId);
# }}}
CREATE UNIQUE INDEX Users1 ON Users (Name) ;
-CREATE INDEX Users2 ON Users (Name);
-CREATE INDEX Users3 ON Users (id, EmailAddress);
CREATE INDEX Users4 ON Users (EmailAddress);
CREATE INDEX Tickets1 ON Tickets (Queue, Status) ;
CREATE INDEX Tickets2 ON Tickets (Owner) ;
-CREATE INDEX Tickets3 ON Tickets (EffectiveId) ;
-CREATE INDEX Tickets4 ON Tickets (id, Status) ;
-CREATE INDEX Tickets5 ON Tickets (id, EffectiveId) ;
CREATE INDEX Tickets6 ON Tickets (EffectiveId, Type) ;
# }}}
# }}}
-# {{{ TicketCustomFieldValues
+# {{{ ObjectCustomFieldValues
-CREATE TABLE TicketCustomFieldValues (
+CREATE TABLE ObjectCustomFieldValues (
id INTEGER NOT NULL AUTO_INCREMENT,
- Ticket int NOT NULL ,
CustomField int NOT NULL ,
+ ObjectType varchar(255) NOT NULL, # Final target of the Object
+ ObjectId int NOT NULL , # New -- Replaces Ticket
+ SortOrder integer NOT NULL DEFAULT 0 , # New -- ordering for multiple values
+
Content varchar(255) NULL ,
+ LargeContent LONGTEXT NULL, # New -- to hold 255+ strings
+ ContentType varchar(80) NULL, # New -- only text/* gets searched
+ ContentEncoding varchar(80) NULL , # New -- for binary Content
Creator integer NOT NULL DEFAULT 0 ,
Created DATETIME NULL ,
LastUpdatedBy integer NOT NULL DEFAULT 0 ,
LastUpdated DATETIME NULL ,
+ Disabled int2 NOT NULL DEFAULT 0 , # New -- whether the value was current
PRIMARY KEY (id)
) TYPE=InnoDB;
+CREATE INDEX ObjectCustomFieldValues1 ON ObjectCustomFieldValues (Content);
+CREATE INDEX ObjectCustomFieldValues2 ON ObjectCustomFieldValues (CustomField,ObjectType,ObjectId);
+
# }}}
# {{{ CustomFields
CREATE TABLE CustomFields (
id INTEGER NOT NULL AUTO_INCREMENT,
Name varchar(200) NULL ,
- Type varchar(200) NULL ,
- Queue integer NOT NULL DEFAULT 0 ,
+ Type varchar(200) NULL , # Changed -- 'Single' and 'Multiple' is moved out
+ MaxValues integer, # New -- was 'Single'(1) and 'Multiple'(0)
+ Pattern varchar(255) NULL , # New -- Must validate against this
+ Repeated int2 NOT NULL DEFAULT 0 , # New -- repeated table entry
Description varchar(255) NULL ,
SortOrder integer NOT NULL DEFAULT 0 ,
+ LookupType varchar(255) NOT NULL,
Creator integer NOT NULL DEFAULT 0 ,
Created DATETIME NULL ,
PRIMARY KEY (id)
) TYPE=InnoDB;
-CREATE INDEX CustomFields1 on CustomFields (Disabled, Queue);
+# }}}
+
+# {{{ ObjectCustomFields
+CREATE TABLE ObjectCustomFields (
+ id INTEGER NOT NULL AUTO_INCREMENT,
+ CustomField int NOT NULL ,
+ ObjectId integer NOT NULL,
+ SortOrder integer NOT NULL DEFAULT 0 ,
+
+ Creator integer NOT NULL DEFAULT 0 ,
+ Created DATETIME NULL ,
+ LastUpdatedBy integer NOT NULL DEFAULT 0 ,
+ LastUpdated DATETIME NULL ,
+ PRIMARY KEY (id)
+) TYPE=InnoDB;
# }}}
PRIMARY KEY (id)
) TYPE=InnoDB;
+CREATE INDEX CustomFieldValues1 ON CustomFieldValues (CustomField);
+
+# }}}
+
+
+# {{{ Attributes
+
+CREATE TABLE Attributes (
+ id INTEGER NOT NULL AUTO_INCREMENT,
+ Name varchar(255) NULL ,
+ Description varchar(255) NULL ,
+ Content text,
+ ContentType varchar(16),
+ ObjectType varchar(64),
+ ObjectId integer, # foreign key to anything
+ Creator integer NOT NULL DEFAULT 0 ,
+ Created DATETIME NULL ,
+ LastUpdatedBy integer NOT NULL DEFAULT 0 ,
+ LastUpdated DATETIME NULL ,
+ PRIMARY KEY (id)
+) TYPE=InnoDB;
+
+CREATE INDEX Attributes1 on Attributes(Name);
+CREATE INDEX Attributes2 on Attributes(ObjectType, ObjectId);
+
# }}}
# {{{ Sessions
$MasonSessionDir
);
-$VERSION = '3.0.4';
+$VERSION = '3.0.9';
$CORE_CONFIG_FILE = "/opt/rt3/etc/RT_Config.pm";
$SITE_CONFIG_FILE = "/opt/rt3/etc/RT_SiteConfig.pm";
=cut
sub Init {
- require RT::Handle;
+
#Get a database connection
- unless ($Handle && $Handle->dbh->ping) {
- $Handle = RT::Handle->new();
- }
- $Handle->Connect();
-
+ ConnectToDatabase();
+
#RT's system user is a genuine database user. its id lives here
$SystemUser = new RT::CurrentUser();
$SystemUser->LoadByName('RT_System');
InitLogging();
}
+
+=head2 ConnectToDatabase
+
+Get a database connection
+
+=cut
+
+sub ConnectToDatabase {
+ require RT::Handle;
+ unless ($Handle && $Handle->dbh && $Handle->dbh->ping) {
+ $Handle = RT::Handle->new();
+ }
+ $Handle->Connect();
+}
+
=head2 InitLogging
Create the RT::Logger object.
=head1 BUGS
+Please report them to rt-3.0-bugs@fsck.com, if you know what's broken and have at least some idea of what needs to be fixed.
+If you're not sure what's going on, report them rt-devel@lists.fsck.com.
+
=head1 SEE ALSO
+L<RT::StyleGuide>
+L<DBIx::SearchBuilder>
+
+
=begin testing
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item PrincipalType
+=head2 PrincipalType
Returns the current value of PrincipalType.
(In the database, PrincipalType is stored as varchar(25).)
-=item SetPrincipalType VALUE
+=head2 SetPrincipalType VALUE
Set PrincipalType to VALUE.
=cut
-=item PrincipalId
+=head2 PrincipalId
Returns the current value of PrincipalId.
(In the database, PrincipalId is stored as int(11).)
-=item SetPrincipalId VALUE
+=head2 SetPrincipalId VALUE
Set PrincipalId to VALUE.
=cut
-=item RightName
+=head2 RightName
Returns the current value of RightName.
(In the database, RightName is stored as varchar(25).)
-=item SetRightName VALUE
+=head2 SetRightName VALUE
Set RightName to VALUE.
=cut
-=item ObjectType
+=head2 ObjectType
Returns the current value of ObjectType.
(In the database, ObjectType is stored as varchar(25).)
-=item SetObjectType VALUE
+=head2 SetObjectType VALUE
Set ObjectType to VALUE.
=cut
-=item ObjectId
+=head2 ObjectId
Returns the current value of ObjectId.
(In the database, ObjectId is stored as int(11).)
-=item SetObjectId VALUE
+=head2 SetObjectId VALUE
Set ObjectId to VALUE.
=cut
-=item DelegatedBy
+=head2 DelegatedBy
Returns the current value of DelegatedBy.
(In the database, DelegatedBy is stored as int(11).)
-=item SetDelegatedBy VALUE
+=head2 SetDelegatedBy VALUE
Set DelegatedBy to VALUE.
=cut
-=item DelegatedFrom
+=head2 DelegatedFrom
Returns the current value of DelegatedFrom.
(In the database, DelegatedFrom is stored as int(11).)
-=item SetDelegatedFrom VALUE
+=head2 SetDelegatedFrom VALUE
Set DelegatedFrom to VALUE.
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
PrincipalType =>
- {read => 1, write => 1, type => 'varchar(25)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 25, is_blob => 0, is_numeric => 0, type => 'varchar(25)', default => ''},
PrincipalId =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
RightName =>
- {read => 1, write => 1, type => 'varchar(25)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 25, is_blob => 0, is_numeric => 0, type => 'varchar(25)', default => ''},
ObjectType =>
- {read => 1, write => 1, type => 'varchar(25)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 25, is_blob => 0, is_numeric => 0, type => 'varchar(25)', default => ''},
ObjectId =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
DelegatedBy =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
DelegatedFrom =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::ACE item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
#
+# CONTRIBUTION SUBMISSION POLICY:
#
-# END LICENSE BLOCK
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
package RT::Action::Autoreply;
require RT::Action::SendEmail;
use vars qw/@ISA/;
@ISA = qw(RT::Action::SendEmail);
+=head2 Prepare
+
+Set up the relevant recipients, then call our parent.
+
+=cut
+
+
+sub Prepare {
+ my $self = shift;
+ $self->SetRecipients();
+ $self->SUPER::Prepare();
+}
# {{{ sub SetRecipients
}
unless ($self->TemplateObj->MIMEObj->head->get('From')) {
- my $friendly_name = $self->TicketObj->QueueObj->Description ||
- $self->TicketObj->QueueObj->Name;
- $friendly_name =~ s/"/\\"/g;
- $self->SetHeader('From', "\"$friendly_name\" <$replyto>");
+ if ($RT::UseFriendlyFromLine) {
+ my $friendly_name = $self->TicketObj->QueueObj->Description ||
+ $self->TicketObj->QueueObj->Name;
+ $friendly_name =~ s/"/\\"/g;
+ $self->SetHeader( 'From',
+ sprintf($RT::FriendlyFromLineFormat,
+ $self->MIMEEncodeString( $friendly_name, $RT::EmailOutputEncoding ), $replyto),
+ );
+ }
+ else {
+ $self->SetHeader( 'From', $replyto );
+ }
}
unless ($self->TemplateObj->MIMEObj->head->get('Reply-To')) {
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
=head1 NAME
RT::Action::Generic - a generic baseclass for RT Actions
package RT::Action::Generic;
use strict;
+use Scalar::Util;
+
+use base qw/RT::Base/;
# {{{ sub new
sub new {
}
# }}}
-# {{{ sub new
-sub loc {
- my $self = shift;
- return $self->{'ScripObj'}->loc(@_);
-}
-# }}}
-
# {{{ sub _Init
sub _Init {
my $self = shift;
- my %args = ( TransactionObj => undef,
- TicketObj => undef,
- ScripObj => undef,
- TemplateObj => undef,
- Argument => undef,
- Type => undef,
- @_ );
-
-
+ my %args = ( Argument => undef,
+ CurrentUser => undef,
+ ScripActionObj => undef,
+ ScripObj => undef,
+ TemplateObj => undef,
+ TicketObj => undef,
+ TransactionObj => undef,
+ Type => undef,
+
+ @_ );
+
$self->{'Argument'} = $args{'Argument'};
+ $self->CurrentUser( $args{'CurrentUser'});
+ $self->{'ScripActionObj'} = $args{'ScripActionObj'};
$self->{'ScripObj'} = $args{'ScripObj'};
+ $self->{'TemplateObj'} = $args{'TemplateObj'};
$self->{'TicketObj'} = $args{'TicketObj'};
$self->{'TransactionObj'} = $args{'TransactionObj'};
- $self->{'TemplateObj'} = $args{'TemplateObj'};
$self->{'Type'} = $args{'Type'};
+
+ Scalar::Util::weaken($self->{'ScripActionObj'});
+ Scalar::Util::weaken($self->{'ScripObj'});
+ Scalar::Util::weaken($self->{'TemplateObj'});
+ Scalar::Util::weaken($self->{'TicketObj'});
+ Scalar::Util::weaken($self->{'TransactionObj'});
+
}
# }}}
}
# }}}
+# {{{ sub ScripActionObj
+sub ScripActionObj {
+ my $self = shift;
+ return($self->{'ScripActionObj'});
+}
+# }}}
+
# {{{ sub Type
sub Type {
my $self = shift;
# We need to clean up all the references that might maybe get
# oddly circular
+ $self->{'ScripActionObj'} = undef;
+ $self->{'ScripObj'} = undef;
$self->{'TemplateObj'} =undef
$self->{'TicketObj'} = undef;
$self->{'TransactionObj'} = undef;
- $self->{'ScripObj'} = undef;
-
-
-
}
# }}}
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
+#
package RT::Action::Notify;
require RT::Action::SendEmail;
-
+use Mail::Address;
use strict;
use vars qw/@ISA/;
@ISA = qw(RT::Action::SendEmail);
+
+=head2 Prepare
+
+Set up the relevant recipients, then call our parent.
+
+=cut
+
+
+sub Prepare {
+ my $self = shift;
+ $self->SetRecipients();
+ $self->SUPER::Prepare();
+}
+
# {{{ sub SetRecipients
=head2 SetRecipients
my ( @To, @PseudoTo, @Cc, @Bcc );
- if ($arg =~ /\bOtherRecipients\b/) {
- if ($self->TransactionObj->Attachments->First) {
- push (@Cc, $self->TransactionObj->Attachments->First->GetHeader('RT-Send-Cc'));
- push (@Bcc, $self->TransactionObj->Attachments->First->GetHeader('RT-Send-Bcc'));
+ if ( $arg =~ /\bOtherRecipients\b/ ) {
+ if ( $self->TransactionObj->Attachments->First ) {
+ my @cc_addresses = Mail::Address->parse($self->TransactionObj->Attachments->First->GetHeader('RT-Send-Cc'));
+ foreach my $addr (@cc_addresses) {
+ push @Cc, $addr->address;
+ }
+ my @bcc_addresses = Mail::Address->parse($self->TransactionObj->Attachments->First->GetHeader('RT-Send-Bcc'));
+
+ foreach my $addr (@bcc_addresses) {
+ push @Bcc, $addr->address;
+ }
+
}
}
@{ $self->{'Bcc'} } = @Bcc;
}
else {
- @{ $self->{'To'} } = grep ( !/^$creator$/, @To );
- @{ $self->{'Cc'} } = grep ( !/^$creator$/, @Cc );
- @{ $self->{'Bcc'} } = grep ( !/^$creator$/, @Bcc );
+ @{ $self->{'To'} } = grep ( lc $_ ne lc $creator, @To );
+ @{ $self->{'Cc'} } = grep ( lc $_ ne lc $creator, @Cc );
+ @{ $self->{'Bcc'} } = grep ( lc $_ ne lc $creator, @Bcc );
}
@{ $self->{'PseudoTo'} } = @PseudoTo;
- return (1);
+
}
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
package RT::Action::NotifyAsComment;
require RT::Action::Notify;
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# This Action will resolve all members of a resolved group ticket
package RT::Action::ResolveMembers;
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
# Portions Copyright 2000 Tobias Brox <tobix@cpan.org>
package RT::Action::SendEmail;
use MIME::Words qw(encode_mimeword);
use RT::EmailParser;
+use Mail::Address;
=head1 NAME
Basically, you create another module RT::Action::YourAction which ISA
RT::Action::SendEmail.
-If you want to set the recipients of the mail to something other than
-the addresses mentioned in the To, Cc, Bcc and headers in
-the template, you should subclass RT::Action::SendEmail and override
-either the SetRecipients method or the SetTo, SetCc, etc methods (see
-the comments for the SetRecipients sub).
-
-
=begin testing
ok (require RT::Action::SendEmail);
# {{{ Scrip methods (_Init, Commit, Prepare, IsApplicable)
-# {{{ sub _Init
-# We use _Init from RT::Action
-# }}}
# {{{ sub Commit
-#Do what we need to do and send it out.
+
sub Commit {
my $self = shift;
- my $MIMEObj = $self->TemplateObj->MIMEObj;
- my $msgid = $MIMEObj->head->get('Message-Id');
- chomp $msgid;
- $RT::Logger->info($msgid." #".$self->TicketObj->id."/".$self->TransactionObj->id." - Scrip ". $self->ScripObj->id ." ".$self->ScripObj->Description);
- #send the email
+ return($self->SendMessage($self->TemplateObj->MIMEObj));
+}
- # Weed out any RT addresses. We really don't want to talk to ourselves!
- @{$self->{'To'}} = RT::EmailParser::CullRTAddresses("", @{$self->{'To'}});
- @{$self->{'Cc'}} = RT::EmailParser::CullRTAddresses("", @{$self->{'Cc'}});
- @{$self->{'Bcc'}} = RT::EmailParser::CullRTAddresses("", @{$self->{'Bcc'}});
- # If there are no recipients, don't try to send the message.
- # If the transaction has content and has the header RT-Squelch-Replies-To
+# }}}
- if ( defined $self->TransactionObj->Attachments->First() ) {
+# {{{ sub Prepare
- my $squelch = $self->TransactionObj->Attachments->First->GetHeader( 'RT-Squelch-Replies-To');
+sub Prepare {
+ my $self = shift;
- if ($squelch) {
- my @blacklist = split ( /,/, $squelch );
-
- # Cycle through the people we're sending to and pull out anyone on the
- # system blacklist
-
- foreach my $person_to_yank (@blacklist) {
- $person_to_yank =~ s/\s//g;
- @{ $self->{'To'} } =
- grep ( !/^$person_to_yank$/, @{ $self->{'To'} } );
- @{ $self->{'Cc'} } =
- grep ( !/^$person_to_yank$/, @{ $self->{'Cc'} } );
- @{ $self->{'Bcc'} } =
- grep ( !/^$person_to_yank$/, @{ $self->{'Bcc'} } );
- }
- }
+ my ( $result, $message ) = $self->TemplateObj->Parse(
+ Argument => $self->Argument,
+ TicketObj => $self->TicketObj,
+ TransactionObj => $self->TransactionObj
+ );
+ if ( !$result ) {
+ return (undef);
}
+ my $MIMEObj = $self->TemplateObj->MIMEObj;
+
+ # Header
+ $self->SetRTSpecialHeaders();
+
+ $self->RemoveInappropriateRecipients();
+
# Go add all the Tos, Ccs and Bccs that we need to to the message to
# make it happy, but only if we actually have values in those arrays.
- $self->SetHeader( 'To', join ( ',', @{ $self->{'To'} } ) )
- if ( $self->{'To'} && @{ $self->{'To'} } );
- $self->SetHeader( 'Cc', join ( ',', @{ $self->{'Cc'} } ) )
- if ( $self->{'Cc'} && @{ $self->{'Cc'} } );
- $self->SetHeader( 'Bcc', join ( ',', @{ $self->{'Bcc'} } ) )
- if ( $self->{'Cc'} && @{ $self->{'Bcc'} } );
+ # TODO: We should be pulling the recipients out of the template and shove them into To, Cc and Bcc
+
+ $self->SetHeader( 'To', join ( ', ', @{ $self->{'To'} } ) )
+ if ( ! $MIMEObj->head->get('To') && $self->{'To'} && @{ $self->{'To'} } );
+ $self->SetHeader( 'Cc', join ( ', ', @{ $self->{'Cc'} } ) )
+ if ( !$MIMEObj->head->get('Cc') && $self->{'Cc'} && @{ $self->{'Cc'} } );
+ $self->SetHeader( 'Bcc', join ( ', ', @{ $self->{'Bcc'} } ) )
+ if ( !$MIMEObj->head->get('Bcc') && $self->{'Bcc'} && @{ $self->{'Bcc'} } );
+ # PseudoTo (fake to headers) shouldn't get matched for message recipients.
+ # If we don't have any 'To' header (but do have other recipients), drop in
+ # the pseudo-to header.
+ $self->SetHeader( 'To', join ( ', ', @{ $self->{'PseudoTo'} } ) )
+ if ( $self->{'PseudoTo'} && ( @{ $self->{'PseudoTo'} } )
+ and ( !$MIMEObj->head->get('To') ) ) and ( $MIMEObj->head->get('Cc') or $MIMEObj->head->get('Bcc'));
- $self->SetHeader('MIME-Version', '1.0');
+ # We should never have to set the MIME-Version header
+ $self->SetHeader( 'MIME-Version', '1.0' );
# try to convert message body from utf-8 to $RT::EmailOutputEncoding
$self->SetHeader( 'Content-Type', 'text/plain; charset="utf-8"' );
- RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, $RT::EmailOutputEncoding, 'mime_words_ok' );
- $self->SetHeader( 'Content-Type', 'text/plain; charset="' . $RT::EmailOutputEncoding . '"' );
+ # fsck.com #5959: Since RT sends 8bit mail, we should say so.
+ $self->SetHeader( 'Content-Transfer-Encoding','8bit');
- # Build up a MIME::Entity that looks like the original message.
-
- my $do_attach = $self->TemplateObj->MIMEObj->head->get('RT-Attach-Message');
+ RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, $RT::EmailOutputEncoding,
+ 'mime_words_ok' );
+ $self->SetHeader( 'Content-Type', 'text/plain; charset="' . $RT::EmailOutputEncoding . '"' );
- if ($do_attach) {
- $self->TemplateObj->MIMEObj->head->delete('RT-Attach-Message');
+ # Build up a MIME::Entity that looks like the original message.
+ $self->AddAttachments() if ( $MIMEObj->head->get('RT-Attach-Message') );
- my $attachments = RT::Attachments->new($RT::SystemUser);
- $attachments->Limit( FIELD => 'TransactionId',
- VALUE => $self->TransactionObj->Id );
- $attachments->OrderBy('id');
+ return $result;
- my $transaction_content_obj = $self->TransactionObj->ContentObj;
+}
- # attach any of this transaction's attachments
- while ( my $attach = $attachments->Next ) {
+# }}}
- # Don't attach anything blank
- next unless ( $attach->ContentLength );
+# }}}
- # We want to make sure that we don't include the attachment that's being sued as the "Content" of this message"
- next
- if ( $transaction_content_obj
- && $transaction_content_obj->Id == $attach->Id
- && $transaction_content_obj->ContentType =~ qr{text/plain}i
- );
- $MIMEObj->make_multipart('mixed');
- $MIMEObj->attach( Type => $attach->ContentType,
- Charset => $attach->OriginalEncoding,
- Data => $attach->OriginalContent,
- Filename => $self->MIMEEncodeString( $attach->Filename, $RT::EmailOutputEncoding ),
- Encoding => '-SUGGEST');
- }
- }
+=head2 To
- my $retval = $self->SendMessage($MIMEObj);
+Returns an array of Mail::Address objects containing all the To: recipients for this notification
+=cut
- return ($retval);
+sub To {
+ my $self = shift;
+ return ($self->_AddressesFromHeader('To'));
}
-# }}}
+=head2 Cc
-# {{{ sub Prepare
+Returns an array of Mail::Address objects containing all the Cc: recipients for this notification
-sub Prepare {
- my $self = shift;
+=cut
- # This actually populates the MIME::Entity fields in the Template Object
+sub Cc {
+ my $self = shift;
+ return ($self->_AddressesFromHeader('Cc'));
+}
- unless ( $self->TemplateObj ) {
- $RT::Logger->warning("No template object handed to $self\n");
- }
+=head2 Bcc
- unless ( $self->TransactionObj ) {
- $RT::Logger->warning("No transaction object handed to $self\n");
+Returns an array of Mail::Address objects containing all the Bcc: recipients for this notification
- }
+=cut
- unless ( $self->TicketObj ) {
- $RT::Logger->warning("No ticket object handed to $self\n");
- }
+sub Bcc {
+ my $self = shift;
+ return ($self->_AddressesFromHeader('Bcc'));
- my ( $result, $message ) = $self->TemplateObj->Parse(
- Argument => $self->Argument,
- TicketObj => $self->TicketObj,
- TransactionObj => $self->TransactionObj
- );
- if ($result) {
-
- # Header
- $self->SetSubject();
- $self->SetSubjectToken();
- $self->SetRecipients();
- $self->SetReturnAddress();
- $self->SetRTSpecialHeaders();
- if ($RT::EmailOutputEncoding) {
-
- # l10n related header
- $self->SetHeaderAsEncoding( 'Subject', $RT::EmailOutputEncoding );
- }
- }
+}
- return $result;
+sub _AddressesFromHeader {
+ my $self = shift;
+ my $field = shift;
+ my $header = $self->TemplateObj->MIMEObj->head->get($field);
+ my @addresses = Mail::Address->parse($header);
+ return (@addresses);
}
-# }}}
-
-# }}}
# {{{ SendMessage
+
=head2 SendMessage MIMEObj
sends the message using RT's preferred API.
-TODO: Break this out to a seperate module
+TODO: Break this out to a separate module
=cut
sub SendMessage {
- my $self = shift;
+ my $self = shift;
my $MIMEObj = shift;
- my $msgid = $MIMEObj->head->get('Message-Id');
+ my $msgid = $MIMEObj->head->get('Message-ID');
+ chomp $msgid;
+ $self->ScripActionObj->{_Message_ID}++;
+
+ $RT::Logger->info( $msgid . " #"
+ . $self->TicketObj->id . "/"
+ . $self->TransactionObj->id
+ . " - Scrip "
+ . $self->ScripObj->id . " "
+ . $self->ScripObj->Description );
#If we don't have any recipients to send to, don't send a message;
- unless ( $MIMEObj->head->get('To')
- || $MIMEObj->head->get('Cc')
- || $MIMEObj->head->get('Bcc') ) {
- $RT::Logger->info($msgid. " No recipients found. Not sending.\n");
+ unless ( $MIMEObj->head->get('To')
+ || $MIMEObj->head->get('Cc')
+ || $MIMEObj->head->get('Bcc') )
+ {
+ $RT::Logger->info( $msgid . " No recipients found. Not sending.\n" );
return (1);
}
- # PseudoTo (fake to headers) shouldn't get matched for message recipients.
- # If we don't have any 'To' header, drop in the pseudo-to header.
- $self->SetHeader( 'To', join ( ',', @{ $self->{'PseudoTo'} } ) )
- if ( $self->{'PseudoTo'} && ( @{ $self->{'PseudoTo'} } )
- and ( !$MIMEObj->head->get('To') ) );
if ( $RT::MailCommand eq 'sendmailpipe' ) {
eval {
- open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" );
- print MAIL $MIMEObj->as_string;
- close(MAIL);
- };
- if ($@) {
- $RT::Logger->crit($msgid. "Could not send mail. -".$@ );
+ open( my $mail, "|$RT::SendmailPath $RT::SendmailArguments" ) || die $!;
+ $MIMEObj->print($mail);
+ close($mail);
+ };
+ if ($@) {
+ $RT::Logger->crit( $msgid . "Could not send mail. -" . $@ );
}
}
else {
- my @mailer_args = ($RT::MailCommand);
- local $ENV{MAILADDRESS};
+ my @mailer_args = ($RT::MailCommand);
+
+ local $ENV{MAILADDRESS};
if ( $RT::MailCommand eq 'sendmail' ) {
- push @mailer_args, $RT::SendmailArguments;
+ push @mailer_args, split(/\s+/, $RT::SendmailArguments);
}
elsif ( $RT::MailCommand eq 'smtp' ) {
- $ENV{MAILADDRESS} = $RT::SMTPFrom || $MIMEObj->head->get('From');
- push @mailer_args, (Server => $RT::SMTPServer);
- push @mailer_args, (Debug => $RT::SMTPDebug);
+ $ENV{MAILADDRESS} = $RT::SMTPFrom || $MIMEObj->head->get('From');
+ push @mailer_args, ( Server => $RT::SMTPServer );
+ push @mailer_args, ( Debug => $RT::SMTPDebug );
+ }
+ else {
+ push @mailer_args, $RT::MailParams;
}
- else {
- push @mailer_args, $RT::MailParams;
- }
- unless ( $MIMEObj->send( @mailer_args ) ) {
- $RT::Logger->crit($msgid. "Could not send mail." );
+ unless ( $MIMEObj->send(@mailer_args) ) {
+ $RT::Logger->crit( $msgid . "Could not send mail." );
return (0);
}
}
-
- my $success = ($msgid. " sent To: ".$MIMEObj->head->get('To') . " Cc: ".$MIMEObj->head->get('Cc') . " Bcc: ".$MIMEObj->head->get('Bcc'));
+ my $success =
+ ( $msgid
+ . " sent To: "
+ . $MIMEObj->head->get('To') . " Cc: "
+ . $MIMEObj->head->get('Cc') . " Bcc: "
+ . $MIMEObj->head->get('Bcc') );
$success =~ s/\n//gi;
+
+ $self->RecordOutgoingMailTransaction($MIMEObj) if ($RT::RecordOutgoingEmail);
+
$RT::Logger->info($success);
return (1);
# }}}
-# {{{ Deal with message headers (Set* subs, designed for easy overriding)
+# {{{ AddAttachments
+
+=head2 AddAttachments
+
+Takes any attachments to this transaction and attaches them to the message
+we're building.
+
+=cut
+
+
+sub AddAttachments {
+ my $self = shift;
+
+ my $MIMEObj = $self->TemplateObj->MIMEObj;
+
+ $MIMEObj->head->delete('RT-Attach-Message');
+
+ my $attachments = RT::Attachments->new($RT::SystemUser);
+ $attachments->Limit(
+ FIELD => 'TransactionId',
+ VALUE => $self->TransactionObj->Id
+ );
+ $attachments->OrderBy( FIELD => 'id');
+
+ my $transaction_content_obj = $self->TransactionObj->ContentObj;
+
+ # attach any of this transaction's attachments
+ while ( my $attach = $attachments->Next ) {
+
+ # Don't attach anything blank
+ next unless ( $attach->ContentLength );
+
+# We want to make sure that we don't include the attachment that's being sued as the "Content" of this message"
+ next
+ if ( $transaction_content_obj
+ && $transaction_content_obj->Id == $attach->Id
+ && $transaction_content_obj->ContentType =~ qr{text/plain}i );
+ $MIMEObj->make_multipart('mixed');
+ $MIMEObj->attach(
+ Type => $attach->ContentType,
+ Charset => $attach->OriginalEncoding,
+ Data => $attach->OriginalContent,
+ Filename => $self->MIMEEncodeString( $attach->Filename,
+ $RT::EmailOutputEncoding ),
+ 'RT-Attachment:' => $self->TicketObj->Id."/".$self->TransactionObj->Id."/".$attach->id,
+ Encoding => '-SUGGEST'
+ );
+ }
+
+}
+
+# }}}
+
+# {{{ RecordOutgoingMailTransaction
+
+=head2 RecordOutgoingMailTransaction MIMEObj
+
+Record a transaction in RT with this outgoing message for future record-keeping purposes
+
+=cut
+
+
+
+sub RecordOutgoingMailTransaction {
+ my $self = shift;
+ my $MIMEObj = shift;
+
+
+ my @parts = $MIMEObj->parts;
+ my @attachments;
+ my @keep;
+ foreach my $part (@parts) {
+ my $attach = $part->head->get('RT-Attachment');
+ if ($attach) {
+ $RT::Logger->debug("We found an attachment. we want to not record it.");
+ push @attachments, $attach;
+ } else {
+ $RT::Logger->debug("We found a part. we want to record it.");
+ push @keep, $part;
+ }
+ }
+ $MIMEObj->parts(\@keep);
+ foreach my $attachment (@attachments) {
+ $MIMEObj->head->add('RT-Attachment', $attachment);
+ }
+
+ RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' );
+
+ my $transaction = RT::Transaction->new($self->TransactionObj->CurrentUser);
+
+ # XXX: TODO -> Record attachments as references to things in the attachments table, maybe.
+
+ my $type;
+ if ($self->TransactionObj->Type eq 'Comment') {
+ $type = 'CommentEmailRecord';
+ } else {
+ $type = 'EmailRecord';
+ }
+
+ my $msgid = $MIMEObj->head->get('Message-ID');
+ chomp $msgid;
+
+ my ( $id, $msg ) = $transaction->Create(
+ Ticket => $self->TicketObj->Id,
+ Type => $type,
+ Data => $msgid,
+ MIMEObj => $MIMEObj,
+ ActivateScrips => 0
+ );
+
+
+}
+
+# }}}
+#
# {{{ sub SetRTSpecialHeaders
sub SetRTSpecialHeaders {
my $self = shift;
- $self->SetReferences();
-
- $self->SetMessageID();
+ $self->SetSubject();
+ $self->SetSubjectToken();
+ $self->SetHeaderAsEncoding( 'Subject', $RT::EmailOutputEncoding )
+ if ($RT::EmailOutputEncoding);
+ $self->SetReturnAddress();
+ $self->SetReferencesHeaders();
+
+ unless ($self->TemplateObj->MIMEObj->head->get('Message-ID')) {
+ # Get Message-ID for this txn
+ my $msgid = "";
+ $msgid = $self->TransactionObj->Message->First->GetHeader("RT-Message-ID")
+ || $self->TransactionObj->Message->First->GetHeader("Message-ID")
+ if $self->TransactionObj->Message && $self->TransactionObj->Message->First;
+
+ # If there is one, and we can parse it, then base our Message-ID on it
+ if ($msgid
+ and $msgid =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\Q$RT::Organization\E>$/
+ "<$1." . $self->TicketObj->id
+ . "-" . $self->ScripObj->id
+ . "-" . $self->ScripActionObj->{_Message_ID}
+ . "@" . $RT::Organization . ">"/eg
+ and $2 == $self->TicketObj->id) {
+ $self->SetHeader( "Message-ID" => $msgid );
+ } else {
+ $self->SetHeader( 'Message-ID',
+ "<rt-"
+ . $RT::VERSION . "-"
+ . $$ . "-"
+ . CORE::time() . "-"
+ . int(rand(2000)) . '.'
+ . $self->TicketObj->id . "-"
+ . $self->ScripObj->id . "-" # Scrip
+ . $self->ScripActionObj->{_Message_ID} . "@" # Email sent
+ . $RT::Organization
+ . ">" );
+ }
+ }
- $self->SetPrecedence();
+ $self->SetHeader( 'Precedence', "bulk" )
+ unless ( $self->TemplateObj->MIMEObj->head->get("Precedence") );
$self->SetHeader( 'X-RT-Loop-Prevention', $RT::rtname );
$self->SetHeader( 'RT-Ticket',
- $RT::rtname . " #" . $self->TicketObj->id() );
+ $RT::rtname . " #" . $self->TicketObj->id() );
$self->SetHeader( 'Managed-by',
- "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
+ "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
$self->SetHeader( 'RT-Originator',
- $self->TransactionObj->CreatorObj->EmailAddress );
- return ();
+ $self->TransactionObj->CreatorObj->EmailAddress );
}
-# {{{ sub SetReferences
+# }}}
+
-=head2 SetReferences
-
- # This routine will set the References: and In-Reply-To headers,
-# autopopulating it with all the correspondence on this ticket so
-# far. This should make RT responses threadable.
+# }}}
+
+# {{{ RemoveInappropriateRecipients
+
+=head2 RemoveInappropriateRecipients
+
+Remove addresses that are RT addresses or that are on this transaction's blacklist
=cut
-sub SetReferences {
+sub RemoveInappropriateRecipients {
my $self = shift;
- # TODO: this one is broken. What is this email really a reply to?
- # If it's a reply to an incoming message, we'll need to use the
- # actual message-id from the appropriate Attachment object. For
- # incoming mails, we would like to preserve the In-Reply-To and/or
- # References.
+ my @blacklist;
- $self->SetHeader( 'In-Reply-To',
- "<rt-" . $self->TicketObj->id() . "\@" . $RT::rtname . ">" );
+ my @types = qw/To Cc Bcc/;
- # TODO We should always add References headers for all message-ids
- # of previous messages related to this ticket.
-}
+ # Weed out any RT addresses. We really don't want to talk to ourselves!
+ foreach my $type (@types) {
+ @{ $self->{$type} } =
+ RT::EmailParser::CullRTAddresses( "", @{ $self->{$type} } );
+ }
-# }}}
+ # If there are no recipients, don't try to send the message.
+ # If the transaction has content and has the header RT-Squelch-Replies-To
-# {{{ sub SetMessageID
+ if ( $self->TransactionObj->Attachments->First() ) {
+ if (
+ $self->TransactionObj->Attachments->First->GetHeader(
+ 'RT-DetectedAutoGenerated')
+ )
+ {
-=head2 SetMessageID
+ # What do we want to do with this? It's probably (?) a bounce
+ # caused by one of the watcher addresses being broken.
+ # Default ("true") is to redistribute, for historical reasons.
-Without this one, threading won't work very nice in email agents.
-Anyway, I'm not really sure it's that healthy if we need to send
-several separate/different emails about the same transaction.
+ if ( !$RT::RedistributeAutoGeneratedMessages ) {
-=cut
+ # Don't send to any watchers.
+ @{ $self->{'To'} } = ();
+ @{ $self->{'Cc'} } = ();
+ @{ $self->{'Bcc'} } = ();
-sub SetMessageID {
- my $self = shift;
+ }
+ elsif ( $RT::RedistributeAutoGeneratedMessages eq 'privileged' ) {
- # TODO this one might be sort of broken. If we have several scrips +++
- # sending several emails to several different persons, we need to
- # pull out different message-ids. I'd suggest message ids like
- # "rt-ticket#-transaction#-scrip#-receipient#"
-
- $self->SetHeader( 'Message-ID',
- "<rt-"
- . $RT::VERSION ."-"
- . $self->TicketObj->id() . "-"
- . $self->TransactionObj->id() . "."
- . rand(20) . "\@"
- . $RT::Organization . ">" )
- unless $self->TemplateObj->MIMEObj->head->get('Message-ID');
-}
+ # Only send to "privileged" watchers.
+ #
-# }}}
+ foreach my $type (@types) {
-# }}}
+ foreach my $addr ( @{ $self->{$type} } ) {
+ my $user = RT::User->new($RT::SystemUser);
+ $user->LoadByEmail($addr);
+ @{ $self->{$type} } =
+ grep ( !/^\Q$addr\E$/, @{ $self->{$type} } )
+ if ( !$user->Privileged );
+
+ }
+ }
+
+ }
+
+ }
+
+ my $squelch =
+ $self->TransactionObj->Attachments->First->GetHeader(
+ 'RT-Squelch-Replies-To');
+
+ if ($squelch) {
+ @blacklist = split( /,/, $squelch );
+ }
+ }
+ # Let's grab the SquelchMailTo attribue and push those entries into the @blacklist
+ my @non_recipients = $self->TicketObj->SquelchMailTo;
+ foreach my $attribute (@non_recipients) {
+ push @blacklist, $attribute->Content;
+ }
+
+ # Cycle through the people we're sending to and pull out anyone on the
+ # system blacklist
+
+ foreach my $person_to_yank (@blacklist) {
+ $person_to_yank =~ s/\s//g;
+ foreach my $type (@types) {
+ @{ $self->{$type} } =
+ grep ( !/^\Q$person_to_yank\E$/, @{ $self->{$type} } );
+ }
+ }
+}
+
+# }}}
# {{{ sub SetReturnAddress
=head2 SetReturnAddress is_comment => BOOLEAN
sub SetReturnAddress {
my $self = shift;
- my %args = ( is_comment => 0,
- @_ );
+ my %args = (
+ is_comment => 0,
+ @_
+ );
# From and Reply-To
# $args{is_comment} should be set if the comment address is to be used.
}
unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
- if ($RT::UseFriendlyFromLine) {
- my $friendly_name = $self->TransactionObj->CreatorObj->RealName;
- if ( $friendly_name =~ /^"(.*)"$/ ) { # a quoted string
- $friendly_name = $1;
- }
-
- $friendly_name =~ s/"/\\"/g;
- $self->SetHeader( 'From',
- sprintf($RT::FriendlyFromLineFormat,
- $self->MIMEEncodeString( $friendly_name, $RT::EmailOutputEncoding ), $replyto),
- );
- }
- else {
- $self->SetHeader( 'From', $replyto );
- }
+ if ($RT::UseFriendlyFromLine) {
+ my $friendly_name = $self->TransactionObj->CreatorObj->RealName;
+ if ( $friendly_name =~ /^"(.*)"$/ ) { # a quoted string
+ $friendly_name = $1;
+ }
+
+ $friendly_name =~ s/"/\\"/g;
+ $self->SetHeader(
+ 'From',
+ sprintf(
+ $RT::FriendlyFromLineFormat,
+ $self->MIMEEncodeString( $friendly_name,
+ $RT::EmailOutputEncoding ),
+ $replyto
+ ),
+ );
+ }
+ else {
+ $self->SetHeader( 'From', $replyto );
+ }
}
unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
# }}}
-# {{{ sub SetRecipients
-
-=head2 SetRecipients
-
-Dummy method to be overriden by subclasses which want to set the recipients.
-
-=cut
-
-sub SetRecipients {
- my $self = shift;
- return ();
-}
-
-# }}}
-
-# {{{ sub SetTo
-
-=head2 SetTo
-
-Takes a string that is the addresses you want to send mail to
-
-=cut
-
-sub SetTo {
- my $self = shift;
- my $addresses = shift;
- return $self->SetHeader( 'To', $addresses );
-}
-
-# }}}
-
-# {{{ sub SetCc
-
-=head2 SetCc
-
-Takes a string that is the addresses you want to Cc
-
-=cut
-
-sub SetCc {
- my $self = shift;
- my $addresses = shift;
-
- return $self->SetHeader( 'Cc', $addresses );
-}
-
-# }}}
-
-# {{{ sub SetBcc
-
-=head2 SetBcc
-
-Takes a string that is the addresses you want to Bcc
-
-=cut
-
-sub SetBcc {
- my $self = shift;
- my $addresses = shift;
-
- return $self->SetHeader( 'Bcc', $addresses );
-}
-
-# }}}
-
-# {{{ sub SetPrecedence
-
-sub SetPrecedence {
- my $self = shift;
-
- unless ( $self->TemplateObj->MIMEObj->head->get("Precedence") ) {
- $self->SetHeader( 'Precedence', "bulk" );
- }
-}
-
-# }}}
# {{{ sub SetSubject
my $self = shift;
my $subject;
- unless ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
- my $message = $self->TransactionObj->Attachments;
- my $ticket = $self->TicketObj->Id;
-
- if ( $self->{'Subject'} ) {
- $subject = $self->{'Subject'};
- }
- elsif ( ( $message->First() )
- && ( $message->First->Headers ) ) {
- my $header = $message->First->Headers();
- $header =~ s/\n\s+/ /g;
- if ( $header =~ /^Subject: (.*?)$/m ) {
- $subject = $1;
- }
- else {
- $subject = $self->TicketObj->Subject();
- }
-
+ my $message = $self->TransactionObj->Attachments;
+ if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
+ return ();
+ }
+ if ( $self->{'Subject'} ) {
+ $subject = $self->{'Subject'};
+ }
+ elsif ( ( $message->First() ) && ( $message->First->Headers ) ) {
+ my $header = $message->First->Headers();
+ $header =~ s/\n\s+/ /g;
+ if ( $header =~ /^Subject: (.*?)$/m ) {
+ $subject = $1;
}
else {
$subject = $self->TicketObj->Subject();
}
- $subject =~ s/(\r\n|\n|\s)/ /gi;
+ }
+ else {
+ $subject = $self->TicketObj->Subject();
+ }
+
+ $subject =~ s/(\r\n|\n|\s)/ /gi;
- chomp $subject;
- $self->SetHeader( 'Subject', $subject );
+ chomp $subject;
+ $self->SetHeader( 'Subject', $subject );
- }
- return ($subject);
}
# }}}
# }}}
+=head2 SetReferencesHeaders
+
+Set References and In-Reply-To headers for this message.
+
+=cut
+
+sub SetReferencesHeaders {
+
+ my $self = shift;
+ my ( @in_reply_to, @references, @msgid );
+
+ my $attachments = $self->TransactionObj->Message;
+
+ if ( my $top = $attachments->First() ) {
+ @in_reply_to = split(/\s+/m, $top->GetHeader('In-Reply-To') || '');
+ @references = split(/\s+/m, $top->GetHeader('References') || '' );
+ @msgid = split(/\s+/m, $top->GetHeader('Message-ID') || '');
+ }
+ else {
+ return (undef);
+ }
+
+ # There are two main cases -- this transaction was created with
+ # the RT Web UI, and hence we want to *not* append its Message-ID
+ # to the References and In-Reply-To. OR it came from an outside
+ # source, and we should treat it as per the RFC
+ if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@$RT::Organization>/) {
+
+ # Make all references which are internal be to version which we
+ # have sent out
+ for (@references, @in_reply_to) {
+ s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@$RT::Organization>$/
+ "<$1." . $self->TicketObj->id .
+ "-" . $self->ScripObj->id .
+ "-" . $self->ScripActionObj->{_Message_ID} .
+ "@" . $RT::Organization . ">"/eg
+ }
+
+ # In reply to whatever the internal message was in reply to
+ $self->SetHeader( 'In-Reply-To', join( " ", ( @in_reply_to )));
+
+ # Default the references to whatever we're in reply to
+ @references = @in_reply_to unless @references;
+
+ # References are unchanged from internal
+ } else {
+ # In reply to that message
+ $self->SetHeader( 'In-Reply-To', join( " ", ( @msgid )));
+
+ # Default the references to whatever we're in reply to
+ @references = @in_reply_to unless @references;
+
+ # Push that message onto the end of the references
+ push @references, @msgid;
+ }
+
+ # Push pseudo-ref to the front
+ my $pseudo_ref = $self->PseudoReference;
+ @references = ($pseudo_ref, grep { $_ ne $pseudo_ref } @references);
+
+ # If there are more than 10 references headers, remove all but the
+ # first four and the last six (Gotta keep this from growing
+ # forever)
+ splice(@references, 4, -6) if ($#references >= 10);
+
+ # Add on the references
+ $self->SetHeader( 'References', join( " ", @references) );
+ $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
+
+}
+
# }}}
-# {{{
+=head2 PseudoReference
+
+Returns a fake Message-ID: header for the ticket to allow a base level of threading
+
+=cut
+
+sub PseudoReference {
+
+ my $self = shift;
+ my $pseudo_ref = '<RT-Ticket-'.$self->TicketObj->id .'@'.$RT::Organization .'>';
+ return $pseudo_ref;
+}
+
+
+# {{{ SetHeadingAsEncoding
=head2 SetHeaderAsEncoding($field_name, $charset_encoding)
}
# }}}
-# {{{ MIMENcodeString
+# {{{ MIMEEncodeString
=head2 MIMEEncodeString STRING ENCODING
sub MIMEEncodeString {
my $self = shift;
my $value = shift;
- my $enc = shift;
+ # using RFC2047 notation, sec 2.
+ # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
+ my $charset = shift;
+ my $encoding = 'B';
+ # An 'encoded-word' may not be more than 75 characters long
+ #
+ # MIME encoding increases 4/3*(number of bytes), and always in multiples
+ # of 4. Thus we have to find the best available value of bytes available
+ # for each chunk.
+ #
+ # First we get the integer max which max*4/3 would fit on space.
+ # Then we find the greater multiple of 3 lower or equal than $max.
+ my $max = int(((75-length('=?'.$charset.'?'.$encoding.'?'.'?='))*3)/4);
+ $max = int($max/3)*3;
chomp $value;
return ($value) unless $value =~ /[^\x20-\x7e]/;
$value =~ s/\s*$//;
Encode::_utf8_off($value);
- my $res = Encode::from_to( $value, "utf-8", $enc );
- $value = encode_mimeword( $value, 'B', $enc );
+ my $res = Encode::from_to( $value, "utf-8", $charset );
+
+ if ($max > 0) {
+ # copy value and split in chuncks
+ my $str=$value;
+ my @chunks = unpack("a$max" x int(length($str)/$max
+ + ((length($str) % $max) ? 1:0)), $str);
+ # encode an join chuncks
+ $value = join " ",
+ map encode_mimeword( $_, $encoding, $charset ), @chunks ;
+ return($value);
+ } else {
+ # gives an error...
+ $RT::Logger->crit("Can't encode! Charset or encoding too big.\n");
+ }
}
# }}}
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item TransactionId
+=head2 TransactionId
Returns the current value of TransactionId.
(In the database, TransactionId is stored as int(11).)
-=item SetTransactionId VALUE
+=head2 SetTransactionId VALUE
Set TransactionId to VALUE.
=cut
-=item Parent
+=head2 Parent
Returns the current value of Parent.
(In the database, Parent is stored as int(11).)
-=item SetParent VALUE
+=head2 SetParent VALUE
Set Parent to VALUE.
=cut
-=item MessageId
+=head2 MessageId
Returns the current value of MessageId.
(In the database, MessageId is stored as varchar(160).)
-=item SetMessageId VALUE
+=head2 SetMessageId VALUE
Set MessageId to VALUE.
=cut
-=item Subject
+=head2 Subject
Returns the current value of Subject.
(In the database, Subject is stored as varchar(255).)
-=item SetSubject VALUE
+=head2 SetSubject VALUE
Set Subject to VALUE.
=cut
-=item Filename
+=head2 Filename
Returns the current value of Filename.
(In the database, Filename is stored as varchar(255).)
-=item SetFilename VALUE
+=head2 SetFilename VALUE
Set Filename to VALUE.
=cut
-=item ContentType
+=head2 ContentType
Returns the current value of ContentType.
(In the database, ContentType is stored as varchar(80).)
-=item SetContentType VALUE
+=head2 SetContentType VALUE
Set ContentType to VALUE.
=cut
-=item ContentEncoding
+=head2 ContentEncoding
Returns the current value of ContentEncoding.
(In the database, ContentEncoding is stored as varchar(80).)
-=item SetContentEncoding VALUE
+=head2 SetContentEncoding VALUE
Set ContentEncoding to VALUE.
=cut
-=item Content
+=head2 Content
Returns the current value of Content.
(In the database, Content is stored as longtext.)
-=item SetContent VALUE
+=head2 SetContent VALUE
Set Content to VALUE.
=cut
-=item Headers
+=head2 Headers
Returns the current value of Headers.
(In the database, Headers is stored as longtext.)
-=item SetHeaders VALUE
+=head2 SetHeaders VALUE
Set Headers to VALUE.
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
TransactionId =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Parent =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
MessageId =>
- {read => 1, write => 1, type => 'varchar(160)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 160, is_blob => 0, is_numeric => 0, type => 'varchar(160)', default => ''},
Subject =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
Filename =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
ContentType =>
- {read => 1, write => 1, type => 'varchar(80)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 80, is_blob => 0, is_numeric => 0, type => 'varchar(80)', default => ''},
ContentEncoding =>
- {read => 1, write => 1, type => 'varchar(80)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 80, is_blob => 0, is_numeric => 0, type => 'varchar(80)', default => ''},
Content =>
- {read => 1, write => 1, type => 'longtext', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'longtext', default => ''},
Headers =>
- {read => 1, write => 1, type => 'longtext', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'longtext', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Attachment item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
package RT::Condition::AnyTransaction;
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
#
+# CONTRIBUTION SUBMISSION POLICY:
#
-# END LICENSE BLOCK
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
=head1 NAME
RT::Condition::Generic - ;
package RT::Condition::Generic;
-use RT::Base;
use strict;
-use vars qw/@ISA/;
-@ISA = qw(RT::Base);
+use base qw/RT::Base/;
# {{{ sub new
sub new {
TemplateObj => undef,
Argument => undef,
ApplicableTransTypes => undef,
+ CurrentUser => undef,
@_ );
$self->{'Argument'} = $args{'Argument'};
$self->{'TicketObj'} = $args{'TicketObj'};
$self->{'TransactionObj'} = $args{'TransactionObj'};
$self->{'ApplicableTransTypes'} = $args{'ApplicableTransTypes'};
+ $self->CurrentUser($args{'CurrentUser'});
}
# }}}
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
=head1 NAME
RT::CurrentUser - an RT object representing the current user
use RT::I18N;
use strict;
-use vars qw/@ISA/;
-@ISA= qw(RT::Record);
+use base qw/RT::Record/;
# {{{ sub _Init
# to be a CurrentUser object. but that's hard to do when we're trying to load
# the CurrentUser object
-sub _Init {
- my $self = shift;
- my $Name = shift;
+sub _Init {
+ my $self = shift;
+ my $User = shift;
- $self->{'table'} = "Users";
+ $self->{'table'} = "Users";
- if (defined($Name)) {
- $self->Load($Name);
- }
-
- $self->CurrentUser($self);
+ if ( defined($User) ) {
+
+ if ( UNIVERSAL::isa( $User, 'RT::User' )
+ || UNIVERSAL::isa( $User, 'RT::CurrentUser' ) )
+ {
+ $self->Load( $User->id );
+
+ }
+ elsif ( ref($User) ) {
+ $RT::Logger->crit(
+ "RT::CurrentUser->new() called with a bogus argument: $User");
+ }
+ else {
+ $self->Load($User);
+ }
+ }
+
+ $self->_BuildTableAttributes();
}
# }}}
sub UserObj {
my $self = shift;
- unless ($self->{'UserObj'}) {
use RT::User;
- $self->{'UserObj'} = RT::User->new($self);
- unless ($self->{'UserObj'}->Load($self->Id)) {
+ my $user = RT::User->new($self);
+
+ unless ($user->Load($self->Id)) {
$RT::Logger->err($self->loc("Couldn't load [_1] from the users database.\n", $self->Id));
}
-
- }
- return ($self->{'UserObj'});
+ return ($user);
}
# }}}
# {{{ sub _Accessible
-sub _Accessible {
- my $self = shift;
- my %Cols = (
- Name => 'read',
- Gecos => 'read',
- RealName => 'read',
- Password => 'neither',
- EmailAddress => 'read',
- Privileged => 'read',
- IsAdministrator => 'read'
- );
- return($self->SUPER::_Accessible(@_, %Cols));
+
+
+ sub _CoreAccessible {
+ {
+ Name => { 'read' => 1 },
+ Gecos => { 'read' => 1 },
+ RealName => { 'read' => 1 },
+ Lang => { 'read' => 1 },
+ Password => { 'read' => 0, 'write' => 0 },
+ EmailAddress => { 'read' => 1, 'write' => 0 }
+ };
+
}
# }}}
Loads a User into this CurrentUser object.
Takes a Name.
+
=cut
sub LoadByName {
if ($identifier !~ /\D/) {
$self->SUPER::LoadById($identifier);
}
+
+ elsif (UNIVERSAL::isa($identifier,"RT::User")) {
+ # DWIM if they pass a user in
+ $self->SUPER::LoadById($identifier->Id);
+ }
else {
# This is a bit dangerous, we might get false authen if somebody
# uses ambigous userids or real names:
=begin testing
ok (my $cu = RT::CurrentUser->new('root'));
-ok (my $lh = $cu->LanguageHandle);
+ok (my $lh = $cu->LanguageHandle('en-us'));
ok ($lh != undef);
ok ($lh->isa('Locale::Maketext'));
-ok ($cu->loc('TEST_STRING') eq "Concrete Mixer", "Localized TEST_STRING into English");
+is ($cu->loc('TEST_STRING'), "Concrete Mixer", "Localized TEST_STRING into English");
ok ($lh = $cu->LanguageHandle('fr'));
-ok ($cu->loc('Before') eq "Avant", "Localized TEST_STRING into Frenc");
+is ($cu->loc('Before'), "Avant", "Localized TEST_STRING into Frenc");
=end testing
sub LanguageHandle {
my $self = shift;
- if ((!defined $self->{'LangHandle'}) ||
- (!UNIVERSAL::can($self->{'LangHandle'}, 'maketext')) ||
- (@_)) {
+ if ( ( !defined $self->{'LangHandle'} )
+ || ( !UNIVERSAL::can( $self->{'LangHandle'}, 'maketext' ) )
+ || (@_) ) {
+ if ( !$RT::SystemUser or ($self->id || 0) == $RT::SystemUser->id() ) {
+ @_ = qw(en-US);
+ }
+
+ elsif ( $self->Lang ) {
+ push @_, $self->Lang;
+ }
$self->{'LangHandle'} = RT::I18N->get_handle(@_);
}
+
# Fall back to english.
- unless ($self->{'LangHandle'}) {
+ unless ( $self->{'LangHandle'} ) {
die "We couldn't get a dictionary. Nye mogu naidti slovar. No puedo encontrar dictionario.";
}
- return ($self->{'LangHandle'});
+ return ( $self->{'LangHandle'} );
}
sub loc {
sub loc_fuzzy {
my $self = shift;
- return '' if $_[0] eq '';
+ return '' if (!$_[0] || $_[0] eq '');
# XXX: work around perl's deficiency when matching utf8 data
return $_[0] if Encode::is_utf8($_[0]);
}
# }}}
+
+=head2 CurrentUser
+
+Return the current currentuser object
+
+=cut
+
+sub CurrentUser {
+ my $self = shift;
+ return($self);
+
+}
+
+=head2 Authenticate
+
+Takes $password, $created and $nonce, and returns a boolean value
+representing whether the authentication succeeded.
+
+If both $nonce and $created are specified, validate $password against:
+
+ encode_base64(sha1(
+ $nonce .
+ $created .
+ sha1_hex( "$username:$realm:$server_pass" )
+ ))
+
+where $server_pass is the md5_hex(password) digest stored in the
+database, $created is in ISO time format, and $nonce is a random
+string no longer than 32 bytes.
+
+=cut
+
+sub Authenticate {
+ my ($self, $password, $created, $nonce, $realm) = @_;
+
+ require Digest::MD5;
+ require Digest::SHA1;
+ require MIME::Base64;
+
+ my $username = $self->UserObj->Name or return;
+ my $server_pass = $self->UserObj->__Value('Password') or return;
+ my $auth_digest = MIME::Base64::encode_base64(Digest::SHA1::sha1(
+ $nonce .
+ $created .
+ Digest::MD5::md5_hex("$username:$realm:$server_pass")
+ ));
+
+ chomp($password);
+ chomp($auth_digest);
+
+ return ($password eq $auth_digest);
+}
+
+# }}}
+
+
eval "require RT::CurrentUser_Vendor";
die $@ if ($@ && $@ !~ qr{^Can't locate RT/CurrentUser_Vendor.pm});
eval "require RT::CurrentUser_Local";
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
+
=head1 NAME
RT::Date - a simple Object Oriented date.
$s = int( $duration / $YEAR );
$time_unit = $self->loc("years");
}
- if (0) { # For now, never display the "AGO" # $negative) {
+
+ if ($negative) {
return $self->loc( "[_1] [_2] ago", $s, $time_unit );
}
else {
# }}}
# {{{ GetWeekday
+
=head2 GetWeekday DAY
Takes an integer day of week and returns a localized string for that day of week
# }}}
# {{{ GetMonth
+
=head2 GetMonth DAY
Takes an integer month and returns a localized string for that month
# }}}
+# {{{ sub W3CDTF
+
+=head2 W3CDTF
+
+Takes nothing
+
+Returns the object's date in W3C DTF format
+
+=cut
+
+sub W3CDTF {
+ my $self = shift;
+ my $date = $self->ISO . 'Z';
+ $date =~ s/ /T/;
+ return $date;
+};
+
+# }}}
# {{{ sub LocalTimezone
+
=head2 LocalTimezone
Returns the current timezone. For now, draws off a system timezone, RT::Timezone. Eventually, this may
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
varchar(255) 'Description'.
varchar(64) 'Domain'.
varchar(64) 'Type'.
- varchar(64) 'Instance'.
+ int(11) 'Instance'.
=cut
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Name
+=head2 Name
Returns the current value of Name.
(In the database, Name is stored as varchar(200).)
-=item SetName VALUE
+=head2 SetName VALUE
Set Name to VALUE.
=cut
-=item Description
+=head2 Description
Returns the current value of Description.
(In the database, Description is stored as varchar(255).)
-=item SetDescription VALUE
+=head2 SetDescription VALUE
Set Description to VALUE.
=cut
-=item Domain
+=head2 Domain
Returns the current value of Domain.
(In the database, Domain is stored as varchar(64).)
-=item SetDomain VALUE
+=head2 SetDomain VALUE
Set Domain to VALUE.
=cut
-=item Type
+=head2 Type
Returns the current value of Type.
(In the database, Type is stored as varchar(64).)
-=item SetType VALUE
+=head2 SetType VALUE
Set Type to VALUE.
=cut
-=item Instance
+=head2 Instance
Returns the current value of Instance.
-(In the database, Instance is stored as varchar(64).)
+(In the database, Instance is stored as int(11).)
-=item SetInstance VALUE
+=head2 SetInstance VALUE
Set Instance to VALUE.
Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
-(In the database, Instance will be stored as a varchar(64).)
+(In the database, Instance will be stored as a int(11).)
=cut
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Name =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Description =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
Domain =>
- {read => 1, write => 1, type => 'varchar(64)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 64, is_blob => 0, is_numeric => 0, type => 'varchar(64)', default => ''},
Type =>
- {read => 1, write => 1, type => 'varchar(64)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 64, is_blob => 0, is_numeric => 0, type => 'varchar(64)', default => ''},
Instance =>
- {read => 1, write => 1, type => 'varchar(64)', default => ''},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item GroupId
+=head2 GroupId
Returns the current value of GroupId.
(In the database, GroupId is stored as int(11).)
-=item SetGroupId VALUE
+=head2 SetGroupId VALUE
Set GroupId to VALUE.
=cut
-=item MemberId
+=head2 MemberId
Returns the current value of MemberId.
(In the database, MemberId is stored as int(11).)
-=item SetMemberId VALUE
+=head2 SetMemberId VALUE
Set MemberId to VALUE.
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
GroupId =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
MemberId =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::GroupMember item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Group item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
=head1 NAME
RT::Handle - RT's database handle
eval "use DBIx::SearchBuilder::Handle::$RT::DatabaseType;
\@ISA= qw(DBIx::SearchBuilder::Handle::$RT::DatabaseType);";
-#TODO check for errors here.
+
+if ($@) {
+ die "Unable to load DBIx::SearchBuilder database handle for '$RT::DatabaseType'.".
+ "\n".
+ "Perhaps you've picked an invalid database type or spelled it incorrectly.".
+ "\n". $@;
+}
=head2 Connect
=cut
sub Connect {
-my $self=shift;
+ my $self = shift;
-# Unless the database port is a positive integer, we really don't want to pass it.
+ if ($RT::DatabaseType eq 'Oracle') {
+ $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
+ $ENV{'NLS_NCHAR'} = "AL32UTF8";
+
+ }
-$self->SUPER::Connect(
+ $self->SUPER::Connect(
User => $RT::DatabaseUser,
Password => $RT::DatabasePassword,
);
+
+ $self->dbh->{LongReadLen} = $RT::MaxAttachmentSize;
}
-=item BuildDSN
+=head2 BuildDSN
Build the DSN for the RT database. doesn't take any parameters, draws all that
from the config file.
=cut
+use File::Spec;
sub BuildDSN {
my $self = shift;
+# Unless the database port is a positive integer, we really don't want to pass it.
$RT::DatabasePort = undef unless (defined $RT::DatabasePort && $RT::DatabasePort =~ /^(\d+)$/);
$RT::DatabaseHost = undef unless (defined $RT::DatabaseHost && $RT::DatabaseHost ne '');
+$RT::DatabaseName = File::Spec->catfile($RT::VarPath, $RT::DatabaseName)
+ if ($RT::DatabaseType eq 'SQLite') and
+ not File::Spec->file_name_is_absolute($RT::DatabaseName);
+
$self->SUPER::BuildDSN(Host => $RT::DatabaseHost,
Database => $RT::DatabaseName,
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
use strict;
use RT;
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
- $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
+ $VERSION = do { my @r = (q$Revision: 1.1.1.3 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
@ISA = qw(Exporter);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
package RT::Interface::Email;
use strict;
use Mail::Address;
use MIME::Entity;
use RT::EmailParser;
-
+use File::Temp;
BEGIN {
use Exporter ();
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
- $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
+ $VERSION = do { my @r = (q$Revision: 1.1.1.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
@ISA = qw(Exporter);
# as well as any optionally exported functions
@EXPORT_OK = qw(
&CreateUser
- &GetMessageContent
- &CheckForLoops
- &CheckForSuspiciousSender
- &CheckForAutoGenerated
- &MailError
- &ParseCcAddressesFromHead
- &ParseSenderAddressFromHead
- &ParseErrorsToAddressFromHead
- &ParseAddressFromHeader
+ &GetMessageContent
+ &CheckForLoops
+ &CheckForSuspiciousSender
+ &CheckForAutoGenerated
+ &CheckForBounce
+ &MailError
+ &ParseCcAddressesFromHead
+ &ParseSenderAddressFromHead
+ &ParseErrorsToAddressFromHead
+ &ParseAddressFromHeader
&Gateway);
}
=head1 NAME
- RT::Interface::CLI - helper functions for creating a commandline RT interface
+ RT::Interface::Email - helper functions for parsing email sent to RT
=head1 SYNOPSIS
my ($From, $junk) = ParseSenderAddressFromHead($head);
- if (($From =~ /^mailer-daemon/i) or
- ($From =~ /^postmaster/i)){
+ if (($From =~ /^mailer-daemon\@/i) or
+ ($From =~ /^postmaster\@/i)){
return (1);
}
if ($Precedence =~ /^(bulk|junk)/i) {
return (1);
}
- else {
- return (0);
+
+ # First Class mailer uses this as a clue.
+ my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
+ if ($FCJunk =~ /^true/i) {
+ return (1);
+ }
+
+ return (0);
+}
+
+# }}}
+
+# {{{ sub CheckForBounce
+sub CheckForBounce {
+ my $head = shift;
+
+ my $ReturnPath = $head->get("Return-path") || "" ;
+ return ($ReturnPath =~ /<>/);
+}
+
+# }}}
+
+# {{{ IsRTAddress
+
+=head2 IsRTAddress ADDRESS
+
+Takes a single parameter, an email address.
+Returns true if that address matches the $RTAddressRegexp.
+Returns false, otherwise.
+
+=cut
+
+sub IsRTAddress {
+ my $address = shift || '';
+
+ # Example: the following rule would tell RT not to Cc
+ # "tickets@noc.example.com"
+ if ( defined($RT::RTAddressRegexp) &&
+ $address =~ /$RT::RTAddressRegexp/i ) {
+ return(1);
+ } else {
+ return (undef);
}
}
# }}}
+# {{{ CullRTAddresses
+
+=head2 CullRTAddresses ARRAY
+
+Takes a single argument, an array of email addresses.
+Returns the same array with any IsRTAddress()es weeded out.
+
+=cut
+
+sub CullRTAddresses {
+ return (grep { IsRTAddress($_) } @_);
+}
+
+# }}}
# {{{ sub MailError
sub MailError {
Subject => 'There has been an error',
Explanation => 'Unexplained error',
MIMEObj => undef,
+ Attach => undef,
LogLevel => 'crit',
@_);
Bcc => $args{'Bcc'},
To => $args{'To'},
Subject => $args{'Subject'},
+ Precedence => 'bulk',
'X-RT-Loop-Prevention' => $RT::rtname,
);
$mimeobj->sync_headers();
$entity->add_part($mimeobj);
}
-
+
+ if ($args{'Attach'}) {
+ $entity->attach(Data => $args{'Attach'}, Type => 'message/rfc822');
+
+ }
+
if ($RT::MailCommand eq 'sendmailpipe') {
- open (MAIL, "|$RT::SendmailPath $RT::SendmailArguments") || return(0);
+ open (MAIL, "|$RT::SendmailPath $RT::SendmailBounceArguments $RT::SendmailArguments") || return(0);
print MAIL $entity->as_string;
close(MAIL);
}
else {
- $entity->send($RT::MailCommand, $RT::MailParams);
+ $entity->send($RT::MailCommand, $RT::MailParams);
}
}
my ($Username, $Address, $Name, $ErrorsTo, $entity) = @_;
my $NewUser = RT::User->new($RT::SystemUser);
- # This data is tainted by some Very Broken mailers.
- # (Sometimes they send raw ISO 8859-1 data here. fear that.
- require Encode;
- $Username = Encode::encode(utf8 => $Username, Encode::FB_PERLQQ()) if defined $Username;
- $Name = Encode::encode(utf8 => $Name, Encode::FB_PERLQQ()) if defined $Name;
-
my ($Val, $Message) =
$NewUser->Create(Name => ($Username || $Address),
EmailAddress => $Address,
return $CurrentUser;
}
-# }}}
+# }}}
+
# {{{ ParseCcAddressesFromHead
=head2 ParseCcAddressesFromHead HASHREF
foreach my $AddrObj (@ToObjs, @CcObjs) {
my $Address = $AddrObj->address;
$Address = $args{'CurrentUser'}->UserObj->CanonicalizeEmailAddress($Address);
- next if ($args{'CurrentUser'}->EmailAddress =~ /^$Address$/i);
- next if ($args{'QueueObj'}->CorrespondAddress =~ /^$Address$/i);
- next if ($args{'QueueObj'}->CommentAddress =~ /^$Address$/i);
- next if (RT::EmailParser::IsRTAddress(undef, $Address));
+ next if ($args{'CurrentUser'}->EmailAddress =~ /^\Q$Address\E$/i);
+ next if ($args{'QueueObj'}->CorrespondAddress =~ /^\Q$Address\E$/i);
+ next if ($args{'QueueObj'}->CommentAddress =~ /^\Q$Address\E$/i);
+ next if (RT::EmailParser->IsRTAddress($Address));
push (@Addresses, $Address);
}
=head2 ParseErrorsToAddressFromHead
Takes a MIME::Header object. Return a single value : user@host
-of the From (evaluated in order of Errors-To:,Reply-To:, From:, Sender)
+of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
+From:, Sender)
=cut
my $head = shift;
#Figure out who's sending this message.
- foreach my $header ('Errors-To' , 'Reply-To', 'From', 'Sender' ) {
+ foreach my $header ('Return-path', 'Errors-To' , 'Reply-To', 'From', 'Sender' ) {
# If there's a header of that name
my $headerobj = $head->get($header);
if ($headerobj) {
sub ParseAddressFromHeader{
my $Addr = shift;
+ # Perl 5.8.0 breaks when doing regex matches on utf8
+ Encode::_utf8_off($Addr) if $] == 5.008;
my @Addresses = Mail::Address->parse($Addr);
my $AddrObj = $Addresses[0];
}
# }}}
+# {{{ sub ParseTicketId
+
+
+sub ParseTicketId {
+ my $Subject = shift;
+ my $id;
+
+ my $test_name = $RT::EmailSubjectTagRegex || qr/\Q$RT::rtname\E/i;
+
+ if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
+ my $id = $1;
+ $RT::Logger->debug("Found a ticket ID. It's $id");
+ return ($id);
+ }
+ else {
+ return (undef);
+ }
+}
+
+# }}}
+
+
+=head2 Gateway ARGSREF
+
+Takes parameters:
+
+ action
+ queue
+ message
-=head2 Gateway
This performs all the "guts" of the mail rt-mailgate program, and is
designed to be called from the web interface with a message, user
object, and so on.
+Can also take an optional 'ticket' parameter; this ticket id overrides
+any ticket id found in the subject.
+
+Returns:
+
+ An array of:
+
+ (status code, message, optional ticket object)
+
+ status code is a numeric value.
+
+ for temporary failures, the status code should be -75
+
+ for permanent failures which are handled by RT, the status code
+ should be 0
+
+ for succces, the status code should be 1
+
+
+
=cut
sub Gateway {
- my %args = ( message => undef,
- queue => 1,
- action => 'correspond',
- ticket => undef,
- @_ );
+ my $argsref = shift;
+
+ my %args = %$argsref;
+
+ # Set some reasonable defaults
+ $args{'action'} ||= 'correspond';
+ $args{'queue'} ||= '1';
# Validate the action
- unless ( $args{'action'} =~ /^(comment|correspond|action)$/ ) {
+ my ($status, @actions) = IsCorrectAction( $args{'action'} );
+ unless ( $status ) {
# Can't safely loc this. What object do we loc around?
- return ( 0, "Invalid 'action' parameter", undef );
+ $RT::Logger->crit("Mail gateway called with an invalid action paramenter '".$actions[0]."' for queue '".$args{'queue'}."'");
+
+ return ( -75, "Invalid 'action' parameter", undef );
}
my $parser = RT::EmailParser->new();
- $parser->ParseMIMEEntityFromScalar( $args{'message'} );
+
+ $parser->SmartParseMIMEEntityFromScalar( Message => $args{'message'});
+
+ if (!$parser->Entity()) {
+ MailError(
+ To => $RT::OwnerEmail,
+ Subject => "RT Bounce: Unparseable message",
+ Explanation => "RT couldn't process the message below",
+ Attach => $args{'message'}
+ );
+
+ return(0,"Failed to parse this message. Something is likely badly wrong with the message");
+ }
my $Message = $parser->Entity();
- my $head = $Message->head;
+ my $head = $Message->head;
- my ( $CurrentUser, $AuthStat, $status, $error );
+ my ( $CurrentUser, $AuthStat, $error );
+
+ # Initalize AuthStat so comparisons work correctly
+ $AuthStat = -9999999;
my $ErrorsTo = ParseErrorsToAddressFromHead($head);
- my $MessageId = $head->get('Message-Id')
+ my $MessageId = $head->get('Message-ID')
|| "<no-message-id-" . time . rand(2000) . "\@.$RT::Organization>";
#Pull apart the subject line
my $Subject = $head->get('Subject') || '';
chomp $Subject;
-
- $args{'ticket'} ||= $parser->ParseTicketId($Subject);
+ $args{'ticket'} ||= ParseTicketId($Subject);
my $SystemTicket;
- if ($args{'ticket'} ) {
+ my $Right = 'CreateTicket';
+ if ( $args{'ticket'} ) {
$SystemTicket = RT::Ticket->new($RT::SystemUser);
- $SystemTicket->Load($args{'ticket'});
+ $SystemTicket->Load( $args{'ticket'} );
+ # if there's an existing ticket, this must be a reply
+ $Right = 'ReplyToTicket';
}
#Set up a queue object
my $SystemQueueObj = RT::Queue->new($RT::SystemUser);
$SystemQueueObj->Load( $args{'queue'} );
-
# We can safely have no queue of we have a known-good ticket
unless ( $args{'ticket'} || $SystemQueueObj->id ) {
- MailError(
- To => $RT::OwnerEmail,
- Subject => "RT Bounce: $Subject",
- Explanation => "RT couldn't find the queue: " . $args{'queue'},
- MIMEObj => $Message );
- return ( 0, "RT couldn't find the queue: " . $args{'queue'}, undef );
+ return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
}
# Authentication Level
- # -1 - Get out. this user has been explicitly declined
+ # -1 - Get out. this user has been explicitly declined
# 0 - User may not do anything (Not used at the moment)
# 1 - Normal user
# 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
- push @RT::MailPlugins, "Auth::MailFrom" unless @RT::MailPlugins;
+ push @RT::MailPlugins, "Auth::MailFrom" unless @RT::MailPlugins;
+
# Since this needs loading, no matter what
- for (@RT::MailPlugins) {
+ foreach (@RT::MailPlugins) {
my $Code;
my $NewAuthStat;
if ( ref($_) eq "CODE" ) {
$Code = $_;
}
else {
- $_ = "RT::Interface::Email::$_" unless /^RT::Interface::Email::/;
+ $_ = "RT::Interface::Email::".$_ unless $_ =~ /^RT::Interface::Email::/;
eval "require $_;";
if ($@) {
- die ("Couldn't load module $_: $@");
+ $RT::Logger->crit("Couldn't load module '$_': $@");
next;
}
no strict 'refs';
if ( !defined( $Code = *{ $_ . "::GetCurrentUser" }{CODE} ) ) {
- die ("No GetCurrentUser code found in $_ module");
+ $RT::Logger->crit("No GetCurrentUser code found in $_ module");
next;
}
}
- ( $CurrentUser, $NewAuthStat ) = $Code->( Message => $Message,
- CurrentUser => $CurrentUser,
- AuthLevel => $AuthStat,
- Action => $args{'action'},
- Ticket => $SystemTicket,
- Queue => $SystemQueueObj );
+ foreach my $action ( @actions ) {
+
+ ( $CurrentUser, $NewAuthStat ) = $Code->(
+ Message => $Message,
+ RawMessageRef => \$args{'message'},
+ CurrentUser => $CurrentUser,
+ AuthLevel => $AuthStat,
+ Action => $action,
+ Ticket => $SystemTicket,
+ Queue => $SystemQueueObj
+ );
+
+
+ # If a module returns a "-1" then we discard the ticket, so.
+ $AuthStat = -1 if $NewAuthStat == -1;
+
+ # You get the highest level of authentication you were assigned.
+ $AuthStat = $NewAuthStat if $NewAuthStat > $AuthStat;
+
+ last if $AuthStat == -1;
+ }
- # You get the highest level of authentication you were assigned.
last if $AuthStat == -1;
- $AuthStat = $NewAuthStat if $NewAuthStat > $AuthStat;
}
# {{{ If authentication fails and no new user was created, get out.
if ( !$CurrentUser or !$CurrentUser->Id or $AuthStat == -1 ) {
# If the plugins refused to create one, they lose.
- MailError(
- Subject => "Could not load a valid user",
- Explanation => <<EOT,
+ unless ( $AuthStat == -1 ) {
+
+ # Notify the RT Admin of the failure.
+ # XXX Should this be configurable?
+ MailError(
+ To => $RT::OwnerEmail,
+ Subject => "Could not load a valid user",
+ Explanation => <<EOT,
RT could not load a valid user, and RT's configuration does not allow
-for the creation of a new user for your email.
+for the creation of a new user for this email ($ErrorsTo).
-Your RT administrator needs to grant 'Everyone' the right 'CreateTicket'
-for this queue.
+You might need to grant 'Everyone' the right '$Right' for the
+queue @{[$args{'queue'}]}.
EOT
- MIMEObj => $Message,
- LogLevel => 'error' )
- unless $AuthStat == -1;
+ MIMEObj => $Message,
+ LogLevel => 'error'
+ );
+
+ # Also notify the requestor that his request has been dropped.
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Could not load a valid user",
+ Explanation => <<EOT,
+RT could not load a valid user, and RT's configuration does not allow
+for the creation of a new user for your email.
+
+EOT
+ MIMEObj => $Message,
+ LogLevel => 'error'
+ );
+ }
return ( 0, "Could not load a valid user", undef );
}
# }}}
# {{{ Lets check for mail loops of various sorts.
+ my $IsBounce = CheckForBounce($head);
+
my $IsAutoGenerated = CheckForAutoGenerated($head);
my $IsSuspiciousSender = CheckForSuspiciousSender($head);
#If the message is autogenerated, we need to know, so we can not
# send mail to the sender
- if ( $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
+ if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
$SquelchReplies = 1;
$ErrorsTo = $RT::OwnerEmail;
}
# {{{ Drop it if it's disallowed
if ( $AuthStat == 0 ) {
MailError(
- To => $ErrorsTo,
- Subject => "Permission Denied",
- Explanation => "You do not have permission to communicate with RT",
- MIMEObj => $Message );
+ To => $ErrorsTo,
+ Subject => "Permission Denied",
+ Explanation => "You do not have permission to communicate with RT",
+ MIMEObj => $Message
+ );
}
# }}}
#Should we mail it to RTOwner?
if ($RT::LoopsToRTOwner) {
- MailError( To => $RT::OwnerEmail,
- Subject => "RT Bounce: $Subject",
- Explanation => "RT thinks this message may be a bounce",
- MIMEObj => $Message );
-
- #Do we actually want to store it?
- return ( 0, "Message Bounced", undef ) unless ($RT::StoreLoops);
+ MailError(
+ To => $RT::OwnerEmail,
+ Subject => "RT Bounce: $Subject",
+ Explanation => "RT thinks this message may be a bounce",
+ MIMEObj => $Message
+ );
}
+
+ #Do we actually want to store it?
+ return ( 0, "Message Bounced", undef ) unless ($RT::StoreLoops);
}
# }}}
# {{{ Squelch replies if necessary
# Don't let the user stuff the RT-Squelch-Replies-To header.
if ( $head->get('RT-Squelch-Replies-To') ) {
- $head->add( 'RT-Relocated-Squelch-Replies-To',
- $head->get('RT-Squelch-Replies-To') );
+ $head->add(
+ 'RT-Relocated-Squelch-Replies-To',
+ $head->get('RT-Squelch-Replies-To')
+ );
$head->delete('RT-Squelch-Replies-To');
}
if ($SquelchReplies) {
- ## TODO: This is a hack. It should be some other way to
- ## indicate that the transaction should be "silent".
+ # Squelch replies to the sender, and also leave a clue to
+ # allow us to squelch ALL outbound messages. This way we
+ # can punt the logic of "what to do when we get a bounce"
+ # to the scrip. We might want to notify nobody. Or just
+ # the RT Owner. Or maybe all Privileged watchers.
my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
$head->add( 'RT-Squelch-Replies-To', $Sender );
+ $head->add( 'RT-DetectedAutoGenerated', 'true' );
}
# }}}
my $Ticket = RT::Ticket->new($CurrentUser);
# {{{ If we don't have a ticket Id, we're creating a new ticket
- if ( !$args{'ticket'} ) {
+ if ( (!$SystemTicket || !$SystemTicket->Id) &&
+ grep /^(comment|correspond)$/, @actions ) {
# {{{ Create a new ticket
my @Requestors = ( $CurrentUser->id );
if ($RT::ParseNewMessageForTicketCcs) {
- @Cc = ParseCcAddressesFromHead( Head => $head,
- CurrentUser => $CurrentUser,
- QueueObj => $SystemQueueObj );
+ @Cc = ParseCcAddressesFromHead(
+ Head => $head,
+ CurrentUser => $CurrentUser,
+ QueueObj => $SystemQueueObj
+ );
}
my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
- Queue => $SystemQueueObj->Id,
- Subject => $Subject,
- Requestor => \@Requestors,
- Cc => \@Cc,
- MIMEObj => $Message );
+ Queue => $SystemQueueObj->Id,
+ Subject => $Subject,
+ Requestor => \@Requestors,
+ Cc => \@Cc,
+ MIMEObj => $Message
+ );
if ( $id == 0 ) {
- MailError( To => $ErrorsTo,
- Subject => "Ticket creation failed",
- Explanation => $ErrStr,
- MIMEObj => $Message );
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Ticket creation failed",
+ Explanation => $ErrStr,
+ MIMEObj => $Message
+ );
$RT::Logger->error("Create failed: $id / $Transaction / $ErrStr ");
return ( 0, "Ticket creation failed", $Ticket );
}
+ # strip comments&corresponds from the actions we don't need record twice
+ @actions = grep !/^(comment|correspond)$/, @actions;
+ $args{'ticket'} = $id;
# }}}
}
- # }}}
+ $Ticket->Load( $args{'ticket'} );
+ unless ( $Ticket->Id ) {
+ my $message = "Could not find a ticket with id " . $args{'ticket'};
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Message not recorded",
+ Explanation => $message,
+ MIMEObj => $Message
+ );
+
+ return ( 0, $message );
+ }
- # If the action is comment, add a comment.
- elsif ( $args{'action'} =~ /^(comment|correspond)$/i ) {
- $Ticket->Load($args{'ticket'});
- unless ( $Ticket->Id ) {
- my $message = "Could not find a ticket with id ".$args{'ticket'};
- MailError( To => $ErrorsTo,
- Subject => "Message not recorded",
- Explanation => $message,
- MIMEObj => $Message );
-
- return ( 0, $message);
+ # }}}
+ foreach my $action( @actions ) {
+ # If the action is comment, add a comment.
+ if ( $action =~ /^(comment|correspond)$/i ) {
+ my ( $status, $msg );
+ if ( $action =~ /^correspond$/i ) {
+ ( $status, $msg ) = $Ticket->Correspond( MIMEObj => $Message );
+ }
+ else {
+ ( $status, $msg ) = $Ticket->Comment( MIMEObj => $Message );
+ }
+ unless ($status) {
+
+ #Warn the sender that we couldn't actually submit the comment.
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Message not recorded",
+ Explanation => $msg,
+ MIMEObj => $Message
+ );
+ return ( 0, "Message not recorded", $Ticket );
+ }
}
-
- my ( $status, $msg );
- if ( $args{'action'} =~ /^correspond$/ ) {
- ( $status, $msg ) = $Ticket->Correspond( MIMEObj => $Message );
+ elsif ($RT::UnsafeEmailCommands && $action =~ /^take$/i ) {
+ my ( $status, $msg ) = $Ticket->SetOwner( $CurrentUser->id );
+ unless ($status) {
+
+ #Warn the sender that we couldn't actually submit the comment.
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Ticket not taken",
+ Explanation => $msg,
+ MIMEObj => $Message
+ );
+ return ( 0, "Ticket not taken", $Ticket );
+ }
}
- else {
- ( $status, $msg ) = $Ticket->Comment( MIMEObj => $Message );
+ elsif ( $RT::UnsafeEmailCommands && $action =~ /^resolve$/i ) {
+ my ( $status, $msg ) = $Ticket->SetStatus( 'resolved' );
+ unless ($status) {
+ #Warn the sender that we couldn't actually submit the comment.
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Ticket not resolved",
+ Explanation => $msg,
+ MIMEObj => $Message
+ );
+ return ( 0, "Ticket not resolved", $Ticket );
+ }
}
- unless ($status) {
-
- #Warn the sender that we couldn't actually submit the comment.
- MailError( To => $ErrorsTo,
- Subject => "Message not recorded",
- Explanation => $msg,
- MIMEObj => $Message );
- return ( 0, "Message not recorded", $Ticket );
+
+ else {
+
+ #Return mail to the sender with an error
+ MailError(
+ To => $ErrorsTo,
+ Subject => "RT Configuration error",
+ Explanation => "'"
+ . $args{'action'}
+ . "' not a recognized action."
+ . " Your RT administrator has misconfigured "
+ . "the mail aliases which invoke RT",
+ MIMEObj => $Message
+ );
+ $RT::Logger->crit( $args{'action'} . " type unknown for $MessageId" );
+ return (
+ -75,
+ "Configuration error: "
+ . $args{'action'}
+ . " not a recognized action",
+ $Ticket
+ );
+
}
}
- else {
-
- #Return mail to the sender with an error
- MailError( To => $ErrorsTo,
- Subject => "RT Configuration error",
- Explanation => "'"
- . $args{'action'}
- . "' not a recognized action."
- . " Your RT administrator has misconfigured "
- . "the mail aliases which invoke RT",
- MIMEObj => $Message );
- $RT::Logger->crit( $args{'action'} . " type unknown for $MessageId" );
- return ( 0, "Configuration error: " . $args{'action'} . " not a recognized action", $Ticket );
-
- }
-
+ return ( 1, "Success", $Ticket );
+}
-return ( 1, "Success", $Ticket );
+sub IsCorrectAction
+{
+ my $action = shift;
+ my @actions = split /-/, $action;
+ foreach ( @actions ) {
+ return (0, $_) unless /^(?:comment|correspond|take|resolve)$/;
+ }
+ return (1, @actions);
}
+
eval "require RT::Interface::Email_Vendor";
die $@ if ($@ && $@ !~ qr{^Can't locate RT/Interface/Email_Vendor.pm});
eval "require RT::Interface::Email_Local";
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
## This is a library of static subs to be used by the Mason web
+# {{{ EscapeUTF8
+=head2 EscapeUTF8 SCALARREF
-# {{{ sub NewApacheHandler
-
-=head2 NewApacheHandler
-
- Takes extra options to pass to HTML::Mason::ApacheHandler->new
- Returns a new Mason::ApacheHandler object
+does a css-busting but minimalist escaping of whatever html you're passing in.
=cut
-sub NewApacheHandler {
- require HTML::Mason::ApacheHandler;
- my $ah = new HTML::Mason::ApacheHandler(
-
- comp_root => [
- [ local => $RT::MasonLocalComponentRoot ],
- [ standard => $RT::MasonComponentRoot ]
- ],
- args_method => "CGI",
- default_escape_flags => 'h',
- allow_globals => [qw(%session)],
- data_dir => "$RT::MasonDataDir",
- @_
- );
+sub EscapeUTF8 {
+ my $ref = shift;
+ return unless defined $$ref;
+ my $val = $$ref;
+ use bytes;
+ $val =~ s/&/&/g;
+ $val =~ s/</</g;
+ $val =~ s/>/>/g;
+ $val =~ s/\(/(/g;
+ $val =~ s/\)/)/g;
+ $val =~ s/"/"/g;
+ $val =~ s/'/'/g;
+ $$ref = $val;
+ Encode::_utf8_on($$ref);
+
- $ah->interp->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
-
- return ($ah);
}
# }}}
-# {{{ sub NewCGIHandler
+# {{{ EscapeURI
-=head2 NewCGIHandler
+=head2 EscapeURI SCALARREF
- Returns a new Mason::CGIHandler object
+Escapes URI component according to RFC2396
=cut
-sub NewCGIHandler {
- my %args = (
- @_
- );
+use Encode qw();
+sub EscapeURI {
+ my $ref = shift;
+ $$ref = Encode::encode_utf8( $$ref );
+ $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
+ Encode::_utf8_on( $$ref );
+}
- my $handler = HTML::Mason::CGIHandler->new(
- comp_root => [
- [ local => $RT::MasonLocalComponentRoot ],
- [ standard => $RT::MasonComponentRoot ]
- ],
- data_dir => "$RT::MasonDataDir",
- default_escape_flags => 'h',
- allow_globals => [qw(%session)]
- );
-
+# }}}
+
+# {{{ WebCanonicalizeInfo
- $handler->interp->set_escape( h => \&RT::Interface::Web::EscapeUTF8 );
+=head2 WebCanonicalizeInfo();
+Different web servers set different environmental varibles. This
+function must return something suitable for REMOTE_USER. By default,
+just downcase $ENV{'REMOTE_USER'}
+
+=cut
- return ($handler);
+sub WebCanonicalizeInfo {
+ my $user;
+ if ( defined $ENV{'REMOTE_USER'} ) {
+ $user = lc ( $ENV{'REMOTE_USER'} ) if( length($ENV{'REMOTE_USER'}) );
+ }
+
+ return $user;
}
+
# }}}
+# {{{ WebExternalAutoInfo
-# {{{ EscapeUTF8
+=head2 WebExternalAutoInfo($user);
-=head2 EscapeUTF8 SCALARREF
-
-does a css-busting but minimalist escaping of whatever html you're passing in.
+Returns a hash of user attributes, used when WebExternalAuto is set.
=cut
-sub EscapeUTF8 {
- my $ref = shift;
- my $val = $$ref;
- use bytes;
- $val =~ s/&/&/g;
- $val =~ s/</</g;
- $val =~ s/>/>/g;
- $val =~ s/\(/(/g;
- $val =~ s/\)/)/g;
- $val =~ s/"/"/g;
- $val =~ s/'/'/g;
- $$ref = $val;
- Encode::_utf8_on($$ref);
+sub WebExternalAutoInfo {
+ my $user = shift;
+
+ my %user_info;
+ $user_info{'Privileged'} = 1;
+
+ if ($^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/) {
+ # Populate fields with information from Unix /etc/passwd
+
+ my ($comments, $realname) = (getpwnam($user))[5, 6];
+ $user_info{'Comments'} = $comments if defined $comments;
+ $user_info{'RealName'} = $realname if defined $realname;
+ }
+ elsif ($^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1') {
+ # Populate fields with information from NT domain controller
+ }
+
+ # and return the wad of stuff
+ return {%user_info};
}
# }}}
UNIVERSAL::can($session{'CurrentUser'}, 'loc')){
return($session{'CurrentUser'}->loc(@_));
}
- else {
- my $u = RT::CurrentUser->new($RT::SystemUser);
+ elsif ( my $u = eval { RT::CurrentUser->new($RT::SystemUser->Id) } ) {
return ($u->loc(@_));
}
+ else {
+ # pathetic case -- SystemUser is gone.
+ return $_[0];
+ }
}
# }}}
return($session{'CurrentUser'}->loc_fuzzy($msg));
}
else {
- my $u = RT::CurrentUser->new($RT::SystemUser);
+ my $u = RT::CurrentUser->new($RT::SystemUser->Id);
return ($u->loc_fuzzy($msg));
}
}
}
my %create_args = (
+ Type => $ARGS{'Type'} || 'ticket',
Queue => $ARGS{'Queue'},
Owner => $ARGS{'Owner'},
InitialPriority => $ARGS{'InitialPriority'},
Starts => $starts->ISO,
MIMEObj => $MIMEObj
);
- foreach my $arg (%ARGS) {
- if ($arg =~ /^CustomField-(\d+)(.*?)$/) {
+ foreach my $arg (keys %ARGS) {
+ my $cfid = $1;
+
next if ($arg =~ /-Magic$/);
- $create_args{"CustomField-".$1} = $ARGS{"$arg"};
+ #Object-RT::Ticket--CustomField-3-Values
+ if ($arg =~ /^Object-RT::Transaction--CustomField-/) {
+ $create_args{$arg} = $ARGS{$arg};
+ }
+ elsif ($arg =~ /^Object-RT::Ticket--CustomField-(\d+)(.*?)$/) {
+ my $cfid = $1;
+ my $cf = RT::CustomField->new( $session{'CurrentUser'});
+ $cf->Load($cfid);
+
+ if ( $cf->Type eq 'Freeform' && ! $cf->SingleValue) {
+ $ARGS{$arg} =~ s/\r\n/\n/g;
+ $ARGS{$arg} = [split('\n', $ARGS{$arg})];
+ }
+
+ if ( $cf->Type =~ /text/i) { # Catch both Text and Wikitext
+ $ARGS{$arg} =~ s/\r//g;
+ }
+
+ if ( $arg =~ /-Upload$/ ) {
+ $create_args{"CustomField-".$cfid} = _UploadedFile($arg);
+ }
+ else {
+ $create_args{"CustomField-".$cfid} = $ARGS{"$arg"};
+ }
}
}
- my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
- unless ( $id && $Trans ) {
- Abort($ErrMsg);
+
+
+ # XXX TODO This code should be about six lines. and badly needs refactoring.
+
+ # {{{ turn new link lists into arrays, and pass in the proper arguments
+ my (@dependson, @dependedonby, @parents, @children, @refersto, @referredtoby);
+
+ foreach my $luri ( split ( / /, $ARGS{"new-DependsOn"} ) ) {
+ $luri =~ s/\s*$//; # Strip trailing whitespace
+ push @dependson, $luri;
}
- my @linktypes = qw( DependsOn MemberOf RefersTo );
+ $create_args{'DependsOn'} = \@dependson;
- foreach my $linktype (@linktypes) {
- foreach my $luri ( split ( / /, $ARGS{"new-$linktype"} ) ) {
- $luri =~ s/\s*$//; # Strip trailing whitespace
- my ( $val, $msg ) = $Ticket->AddLink(
- Target => $luri,
- Type => $linktype
- );
- push ( @Actions, $msg ) unless ($val);
- }
+ foreach my $luri ( split ( / /, $ARGS{"DependsOn-new"} ) ) {
+ push @dependedonby, $luri;
+ }
+ $create_args{'DependedOnBy'} = \@dependedonby;
- foreach my $luri ( split ( / /, $ARGS{"$linktype-new"} ) ) {
- my ( $val, $msg ) = $Ticket->AddLink(
- Base => $luri,
- Type => $linktype
- );
+ foreach my $luri ( split ( / /, $ARGS{"new-MemberOf"} ) ) {
+ $luri =~ s/\s*$//; # Strip trailing whitespace
+ push @parents, $luri;
+ }
+ $create_args{'Parents'} = \@parents;
- push ( @Actions, $msg ) unless ($val);
- }
+ foreach my $luri ( split ( / /, $ARGS{"MemberOf-new"} ) ) {
+ push @children, $luri;
+ }
+ $create_args{'Children'} = \@children;
+
+ foreach my $luri ( split ( / /, $ARGS{"new-RefersTo"} ) ) {
+ $luri =~ s/\s*$//; # Strip trailing whitespace
+ push @refersto, $luri;
+ }
+ $create_args{'RefersTo'} = \@refersto;
+
+ foreach my $luri ( split ( / /, $ARGS{"RefersTo-new"} ) ) {
+ push @referredtoby, $luri;
+ }
+ $create_args{'ReferredToBy'} = \@referredtoby;
+ # }}}
+
+
+ my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
+ unless ( $id && $Trans ) {
+ Abort($ErrMsg);
}
push ( @Actions, split("\n", $ErrMsg) );
);
#Make the update content have no 'weird' newlines in it
- if ( $args{ARGSRef}->{'UpdateContent'} ) {
+ if ( $args{ARGSRef}->{'UpdateTimeWorked'}
+ || $args{ARGSRef}->{'UpdateContent'}
+ || $args{ARGSRef}->{'UpdateAttachments'} )
+ {
if (
$args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject() )
}
my $Message = MakeMIMEEntity(
- Subject => $args{ARGSRef}->{'UpdateSubject'},
- Body => $args{ARGSRef}->{'UpdateContent'},
+ Subject => $args{ARGSRef}->{'UpdateSubject'},
+ Body => $args{ARGSRef}->{'UpdateContent'},
);
- if ($args{ARGSRef}->{'UpdateAttachments'}) {
- $Message->make_multipart;
- $Message->add_part($_) foreach values %{$args{ARGSRef}->{'UpdateAttachments'}};
- }
-
- ## TODO: Implement public comments
- if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
- my ( $Transaction, $Description ) = $args{TicketObj}->Comment(
- CcMessageTo => $args{ARGSRef}->{'UpdateCc'},
- BccMessageTo => $args{ARGSRef}->{'UpdateBcc'},
- MIMEObj => $Message,
- TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
- );
- push ( @{ $args{Actions} }, $Description );
- }
- elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
- my ( $Transaction, $Description ) = $args{TicketObj}->Correspond(
- CcMessageTo => $args{ARGSRef}->{'UpdateCc'},
- BccMessageTo => $args{ARGSRef}->{'UpdateBcc'},
- MIMEObj => $Message,
- TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
- );
- push ( @{ $args{Actions} }, $Description );
+ $Message->head->add( 'Message-ID' =>
+ "<rt-"
+ . $RT::VERSION . "-"
+ . $$ . "-"
+ . CORE::time() . "-"
+ . int(rand(2000)) . "."
+ . $args{'TicketObj'}->id . "-"
+ . "0" . "-" # Scrip
+ . "0" . "@" # Email sent
+ . $RT::Organization
+ . ">" );
+ my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
+ if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
+ $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
}
else {
- push ( @{ $args{'Actions'} },
- loc("Update type was neither correspondence nor comment.").
- " ".
- loc("Update not recorded.")
- );
+ $old_txn = $args{TicketObj}->Transactions->First();
}
+
+ if ( $old_txn->Message && $old_txn->Message->First ) {
+ my @in_reply_to = split(/\s+/m, $old_txn->Message->First->GetHeader('In-Reply-To') || '');
+ my @references = split(/\s+/m, $old_txn->Message->First->GetHeader('References') || '' );
+ my @msgid = split(/\s+/m,$old_txn->Message->First->GetHeader('Message-ID') || '');
+ my @rtmsgid = split(/\s+/m,$old_txn->Message->First->GetHeader('RT-Message-ID') || '');
+
+ $Message->head->replace( 'In-Reply-To', join (' ', @rtmsgid ? @rtmsgid : @msgid));
+ $Message->head->replace( 'References', join(' ', @references, @msgid, @rtmsgid));
+ }
+
+ if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
+ $Message->make_multipart;
+ $Message->add_part($_)
+ foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
+ }
+
+ ## TODO: Implement public comments
+ if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
+ my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(
+ CcMessageTo => $args{ARGSRef}->{'UpdateCc'},
+ BccMessageTo => $args{ARGSRef}->{'UpdateBcc'},
+ MIMEObj => $Message,
+ TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
+ );
+ push( @{ $args{Actions} }, $Description );
+ $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
+ }
+ elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
+ my ( $Transaction, $Description, $Object ) =
+ $args{TicketObj}->Correspond(
+ CcMessageTo => $args{ARGSRef}->{'UpdateCc'},
+ BccMessageTo => $args{ARGSRef}->{'UpdateBcc'},
+ MIMEObj => $Message,
+ TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'}
+ );
+ push( @{ $args{Actions} }, $Description );
+ $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
+ }
+ else {
+ push(
+ @{ $args{'Actions'} },
+ loc("Update type was neither correspondence nor comment.") . " "
+ . loc("Update not recorded.")
+ );
}
}
+}
# }}}
Cc => undef,
Body => undef,
AttachmentFieldName => undef,
- map Encode::encode_utf8($_), @_,
+# map Encode::encode_utf8($_), @_,
+ @_,
);
#Make the update content have no 'weird' newlines in it
Subject => $args{'Subject'} || "",
From => $args{'From'},
Cc => $args{'Cc'},
+ Charset => 'utf8',
Data => [ $args{'Body'} ]
);
}
#foreach my $filehandle (@filenames) {
- my ( $fh, $temp_file ) = tempfile();
+ my ( $fh, $temp_file );
+ for ( 1 .. 10 ) {
+ # on NFS and NTFS, it is possible that tempfile() conflicts
+ # with other processes, causing a race condition. we try to
+ # accommodate this by pausing and retrying.
+ last if ($fh, $temp_file) = eval { tempfile( UNLINK => 1) };
+ sleep 1;
+ }
binmode $fh; #thank you, windows
my ($buffer);
$Message->attach(
Path => $temp_file,
- Filename => $filename,
+ Filename => Encode::decode_utf8($filename),
Type => $uploadinfo->{'Content-Type'},
);
close($fh);
# }}}
# {{{ Limit requestor email
+ if ( $args{ARGS}->{'ValueOfWatcherRole'} ne '' ) {
+ $session{'tickets'}->LimitWatcher(
+ TYPE => $args{ARGS}->{'WatcherRole'},
+ VALUE => $args{ARGS}->{'ValueOfWatcherRole'},
+ OPERATOR => $args{ARGS}->{'WatcherRoleOp'},
- if ( $args{ARGS}->{'ValueOfRequestor'} ne '' ) {
- my $alias = $session{'tickets'}->LimitRequestor(
- VALUE => $args{ARGS}->{'ValueOfRequestor'},
- OPERATOR => $args{ARGS}->{'RequestorOp'},
);
-
}
# }}}
# }}}
-# {{{ sub Config
-# TODO: This might eventually read the cookies, user configuration
-# information from the DB, queue configuration information from the
-# DB, etc.
-
-sub Config {
- my $args = shift;
- my $key = shift;
- return $args->{$key} || $RT::WebOptions{$key};
-}
-
-# }}}
-
# {{{ sub ProcessACLChanges
sub ProcessACLChanges {
my $obj;
- if ($object_type eq 'RT::Queue') {
- $obj = RT::Queue->new($session{'CurrentUser'});
- $obj->Load($object_id);
- } elsif ($object_type eq 'RT::Group') {
- $obj = RT::Group->new($session{'CurrentUser'});
- $obj->Load($object_id);
-
- } elsif ($object_type eq 'RT::System') {
+ if ($object_type eq 'RT::System') {
$obj = $RT::System;
+ } elsif ($RT::ACE::OBJECT_TYPES{$object_type}) {
+ $obj = $object_type->new($session{'CurrentUser'});
+ $obj->Load($object_id);
} else {
- push (@results, loc("System Error").
+ push (@results, loc("System Error"). ': '.
loc("Rights could not be granted for [_1]", $object_type));
next;
}
next unless ($right);
my $obj;
- if ($object_type eq 'RT::Queue') {
- $obj = RT::Queue->new($session{'CurrentUser'});
- $obj->Load($object_id);
- } elsif ($object_type eq 'RT::Group') {
- $obj = RT::Group->new($session{'CurrentUser'});
- $obj->Load($object_id);
-
- } elsif ($object_type eq 'RT::System') {
+ if ($object_type eq 'RT::System') {
$obj = $RT::System;
+ } elsif ($RT::ACE::OBJECT_TYPES{$object_type}) {
+ $obj = $object_type->new($session{'CurrentUser'});
+ $obj->Load($object_id);
} else {
- push (@results, loc("System Error").
+ push (@results, loc("System Error"). ': '.
loc("Rights could not be revoked for [_1]", $object_type));
next;
}
@_
);
- my (@results);
-
- my $object = $args{'Object'};
- my $attributes = $args{'AttributesRef'};
- my $ARGSRef = $args{'ARGSRef'};
- foreach my $attribute (@$attributes) {
- my $value;
- if ( defined $ARGSRef->{$attribute} ) {
- $value = $ARGSRef->{$attribute};
- }
- elsif (
- defined( $args{'AttributePrefix'} )
- && defined(
- $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
- )
- ) {
- $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
-
- } else {
- next;
- }
+ my $Object = $args{'Object'};
+ my @results = $Object->Update(AttributesRef => $args{'AttributesRef'},
+ ARGSRef => $args{'ARGSRef'},
+ AttributePrefix => $args{'AttributePrefix'}
+ );
- $value =~ s/\r\n/\n/gs;
-
- if ($value ne $object->$attribute()){
-
- my $method = "Set$attribute";
- my ( $code, $msg ) = $object->$method($value);
-
- push @results, loc($attribute) . ': ' . loc_fuzzy($msg);
-=for loc
- "[_1] could not be set to [_2].", # loc
- "That is already the current value", # loc
- "No value sent to _Set!\n", # loc
- "Illegal value for [_1]", # loc
- "The new value has been set.", # loc
- "No column specified", # loc
- "Immutable field", # loc
- "Nonexistant field?", # loc
- "Invalid data", # loc
- "Couldn't find row", # loc
- "Missing a primary key?: [_1]", # loc
- "Found Object", # loc
-=cut
- };
- }
return (@results);
}
my ( $err, $msg ) = $Object->DeleteValue($id);
push ( @results, $msg );
}
+
+ my $vals = $Object->Values();
+ while (my $cfv = $vals->Next()) {
+ if (my $so = $ARGSRef->{ 'CustomField-' . $Object->Id . '-SortOrder' . $cfv->Id }) {
+ if ($cfv->SortOrder != $so) {
+ my ( $err, $msg ) = $cfv->SetSortOrder($so);
+ push ( @results, $msg );
+ }
+ }
+ }
+
return (@results);
}
TimeEstimated
TimeWorked
TimeLeft
+ Type
Status
Queue
);
}
}
+
+ # Status isn't a field that can be set to a null value.
+ # RT core complains if you try
+ delete $ARGSRef->{'Status'} unless ($ARGSRef->{'Status'});
+
my @results = UpdateRecordObject(
AttributesRef => \@attribs,
Object => $TicketObj,
# }}}
-# {{{ Sub ProcessTicketCustomFieldUpdates
-
sub ProcessTicketCustomFieldUpdates {
- my %args = (
- ARGSRef => undef,
- @_
- );
+ my %args = @_;
+ $args{'Object'} = delete $args{'TicketObj'};
+ my $ARGSRef = { %{ $args{'ARGSRef'} } };
- my @results;
+ # Build up a list of objects that we want to work with
+ my %custom_fields_to_mod;
+ foreach my $arg ( keys %$ARGSRef ) {
+ if ( $arg =~ /^Ticket-(\d+-.*)/) {
+ $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
+ }
+ elsif ( $arg =~ /^CustomField-(\d+-.*)/) {
+ $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
+ }
+ }
+
+ return ProcessObjectCustomFieldUpdates(%args, ARGSRef => $ARGSRef);
+}
+sub ProcessObjectCustomFieldUpdates {
+ my %args = @_;
my $ARGSRef = $args{'ARGSRef'};
+ my @results;
- # Build up a list of tickets that we want to work with
- my %tickets_to_mod;
+ # Build up a list of objects that we want to work with
my %custom_fields_to_mod;
- foreach my $arg ( keys %{$ARGSRef} ) {
- if ( $arg =~ /^Ticket-(\d+)-CustomField-(\d+)-/ ) {
-
- # For each of those tickets, find out what custom fields we want to work with.
- $custom_fields_to_mod{$1}{$2} = 1;
+ foreach my $arg ( keys %$ARGSRef ) {
+ if ( $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-/ ) {
+ # For each of those objects, find out what custom fields we want to work with.
+ $custom_fields_to_mod{$1}{$2 || $args{'Object'}->Id}{$3} = 1;
}
}
- # For each of those tickets
- foreach my $tick ( keys %custom_fields_to_mod ) {
- my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
- $Ticket->Load($tick);
-
- # For each custom field
- foreach my $cf ( keys %{ $custom_fields_to_mod{$tick} } ) {
-
+ # For each of those objects
+ foreach my $class ( keys %custom_fields_to_mod ) {
+ foreach my $id ( keys %{$custom_fields_to_mod{$class}} ) {
+ my $Object = $args{'Object'};
+ if (!$Object or ref($Object) ne $class or $Object->id != $id) {
+ $Object = $class->new( $session{'CurrentUser'} );
+ $Object->Load($id);
+ }
+
+ # For each custom field
+ foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
my $CustomFieldObj = RT::CustomField->new($session{'CurrentUser'});
$CustomFieldObj->LoadById($cf);
- foreach my $arg ( keys %{$ARGSRef} ) {
- # since http won't pass in a form element with a null value, we need
- # to fake it
- if ($arg =~ /^(.*?)-Values-Magic$/ ) {
- # We don't care about the magic, if there's really a values element;
- next if (exists $ARGSRef->{$1.'-Values'}) ;
-
- $arg = $1."-Values";
- $ARGSRef->{$1."-Values"} = undef;
-
- }
- next unless ( $arg =~ /^Ticket-$tick-CustomField-$cf-/ );
- my @values =
- ( ref( $ARGSRef->{$arg} ) eq 'ARRAY' )
- ? @{ $ARGSRef->{$arg} }
- : ( $ARGSRef->{$arg} );
- if ( ( $arg =~ /-AddValue$/ ) || ( $arg =~ /-Value$/ ) ) {
- foreach my $value (@values) {
- next unless ($value);
- my ( $val, $msg ) = $Ticket->AddCustomFieldValue(
- Field => $cf,
- Value => $value
- );
- push ( @results, $msg );
- }
- }
- elsif ( $arg =~ /-DeleteValues$/ ) {
- foreach my $value (@values) {
- next unless ($value);
- my ( $val, $msg ) = $Ticket->DeleteCustomFieldValue(
+ foreach my $arg ( keys %{$ARGSRef} ) {
+ # Only interested in args for the current CF:
+ next unless ( $arg =~ /^Object-$class-(?:$id)?-CustomField-$cf-/ );
+
+ # since http won't pass in a form element with a null value, we need
+ # to fake it
+ if ($arg =~ /^(.*?)-Values-Magic$/ ) {
+ # We don't care about the magic, if there's really a values element;
+ next if ($ARGSRef->{$1.'-Value'} || $ARGSRef->{$1.'-Values'}) ;
+
+ # "Empty" values does not mean anything for Image and Binary fields
+ next if $CustomFieldObj->Type =~ /^(?:Image|Binary)$/;
+
+ $arg = $1."-Values";
+ $ARGSRef->{$1."-Values"} = undef;
+
+ }
+ my @values = ();
+ if (ref( $ARGSRef->{$arg} ) eq 'ARRAY' ) {
+ @values = @{ $ARGSRef->{$arg} };
+ } elsif ($CustomFieldObj->Type =~ /text/i) { # Both Text and Wikitext
+ @values = ($ARGSRef->{$arg});
+ } else {
+ @values = split /\n/, $ARGSRef->{$arg};
+ }
+
+ if ( ($CustomFieldObj->Type eq 'Freeform'
+ && ! $CustomFieldObj->SingleValue) ||
+ $CustomFieldObj->Type =~ /text/i) {
+ foreach my $val (@values) {
+ $val =~ s/\r//g;
+ }
+ }
+
+ if ( ( $arg =~ /-AddValue$/ ) || ( $arg =~ /-Value$/ ) ) {
+ foreach my $value (@values) {
+ next unless length($value);
+ my ( $val, $msg ) = $Object->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+ }
+ elsif ( $arg =~ /-Upload$/ ) {
+ my $value_hash = _UploadedFile($arg) or next;
+
+ my ( $val, $msg ) = $Object->AddCustomFieldValue(
+ %$value_hash,
Field => $cf,
- Value => $value
- );
- push ( @results, $msg );
- }
- }
- elsif ( $arg =~ /-Values$/ and $CustomFieldObj->Type !~ /Entry/) {
- my $cf_values = $Ticket->CustomFieldValues($cf);
-
- my %values_hash;
- foreach my $value (@values) {
- next unless ($value);
-
- # build up a hash of values that the new set has
- $values_hash{$value} = 1;
-
- unless ( $cf_values->HasEntry($value) ) {
- my ( $val, $msg ) = $Ticket->AddCustomFieldValue(
- Field => $cf,
- Value => $value
- );
- push ( @results, $msg );
- }
-
- }
- while ( my $cf_value = $cf_values->Next ) {
- unless ( $values_hash{ $cf_value->Content } == 1 ) {
- my ( $val, $msg ) = $Ticket->DeleteCustomFieldValue(
- Field => $cf,
- Value => $cf_value->Content
- );
- push ( @results, $msg);
-
- }
-
- }
- }
- elsif ( $arg =~ /-Values$/ ) {
- my $cf_values = $Ticket->CustomFieldValues($cf);
+ );
+ push ( @results, $msg );
+ }
+ elsif ( $arg =~ /-DeleteValues$/ ) {
+ foreach my $value (@values) {
+ next unless length($value);
+ my ( $val, $msg ) = $Object->DeleteCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+ }
+ elsif ( $arg =~ /-DeleteValueIds$/ ) {
+ foreach my $value (@values) {
+ next unless length($value);
+ my ( $val, $msg ) = $Object->DeleteCustomFieldValue(
+ Field => $cf,
+ ValueId => $value,
+ );
+ push ( @results, $msg );
+ }
+ }
+ elsif ( $arg =~ /-Values$/ and !$CustomFieldObj->Repeated) {
+ my $cf_values = $Object->CustomFieldValues($cf);
+
+ my %values_hash;
+ foreach my $value (@values) {
+ next unless length($value);
+
+ # build up a hash of values that the new set has
+ $values_hash{$value} = 1;
+
+ unless ( $cf_values->HasEntry($value) ) {
+ my ( $val, $msg ) = $Object->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+
+ }
+ while ( my $cf_value = $cf_values->Next ) {
+ unless ( $values_hash{ $cf_value->Content } == 1 ) {
+ my ( $val, $msg ) = $Object->DeleteCustomFieldValue(
+ Field => $cf,
+ Value => $cf_value->Content
+ );
+ push ( @results, $msg);
+
+ }
+ }
+ }
+ elsif ( $arg =~ /-Values$/ ) {
+ my $cf_values = $Object->CustomFieldValues($cf);
# keep everything up to the point of difference, delete the rest
my $delete_flag;
# now add/replace extra things, if any
foreach my $value (@values) {
- my ( $val, $msg ) = $Ticket->AddCustomFieldValue(
+ my ( $val, $msg ) = $Object->AddCustomFieldValue(
Field => $cf,
Value => $value
);
push ( @results, $msg );
}
}
- else {
- push ( @results, "User asked for an unknown update type for custom field " . $cf->Name . " for ticket " . $Ticket->id );
- }
- }
- }
- return (@results);
+ else {
+ push ( @results, loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]", $cf->Name, $class, $Object->id ) );
+ }
+ }
+ }
+ return (@results);
+ }
}
}
-# }}}
-
# {{{ sub ProcessTicketWatchers
=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
foreach my $key ( keys %$ARGSRef ) {
# {{{ Delete deletable watchers
- if ( ( $key =~ /^Ticket-DelWatcher-Type-(.*)-Principal-(\d+)$/ ) ) {
+ if ( ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) ) {
my ( $code, $msg ) =
$Ticket->DeleteWatcher(PrincipalId => $2,
Type => $1);
}
# Delete watchers in the simple style demanded by the bulk manipulator
- elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
- my ( $code, $msg ) = $Ticket->DeleteWatcher( Type => $ARGSRef->{$key}, PrincipalId => $1 );
+ elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
+ my ( $code, $msg ) = $Ticket->DeleteWatcher( Email => $ARGSRef->{$key}, Type => $1 );
push @results, $msg;
}
my $Ticket = $args{'TicketObj'};
my $ARGSRef = $args{'ARGSRef'};
+
+ my (@results) = ProcessRecordLinks(RecordObj => $Ticket,
+ ARGSRef => $ARGSRef);
+
+ #Merge if we need to
+ if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
+ my ( $val, $msg ) =
+ $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
+ push @results, $msg;
+ }
+
+ return (@results);
+}
+
+# }}}
+
+sub ProcessRecordLinks {
+ my %args = ( RecordObj => undef,
+ ARGSRef => undef,
+ @_ );
+
+ my $Record = $args{'RecordObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
my (@results);
# Delete links that are gone gone gone.
push @results,
"Trying to delete: Base: $base Target: $target Type $type";
- my ( $val, $msg ) = $Ticket->DeleteLink( Base => $base,
+ my ( $val, $msg ) = $Record->DeleteLink( Base => $base,
Type => $type,
Target => $target );
my @linktypes = qw( DependsOn MemberOf RefersTo );
foreach my $linktype (@linktypes) {
- if ( $ARGSRef->{ $Ticket->Id . "-$linktype" } ) {
- for my $luri ( split ( / /, $ARGSRef->{ $Ticket->Id . "-$linktype" } ) ) {
+ if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
+ for my $luri ( split ( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
$luri =~ s/\s*$//; # Strip trailing whitespace
- my ( $val, $msg ) = $Ticket->AddLink( Target => $luri,
+ my ( $val, $msg ) = $Record->AddLink( Target => $luri,
Type => $linktype );
push @results, $msg;
}
}
- if ( $ARGSRef->{ "$linktype-" . $Ticket->Id } ) {
+ if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
- for my $luri ( split ( / /, $ARGSRef->{ "$linktype-" . $Ticket->Id } ) ) {
- my ( $val, $msg ) = $Ticket->AddLink( Base => $luri,
+ for my $luri ( split ( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
+ my ( $val, $msg ) = $Record->AddLink( Base => $luri,
Type => $linktype );
push @results, $msg;
}
}
- #Merge if we need to
- if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
- my ( $val, $msg ) =
- $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
- push @results, $msg;
- }
-
return (@results);
}
-# }}}
+
+=head2 _UploadedFile ( $arg );
+
+Takes a CGI parameter name; if a file is uploaded under that name,
+return a hash reference suitable for AddCustomFieldValue's use:
+C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
+
+Returns C<undef> if no files were uploaded in the C<$arg> field.
+
+=cut
+
+sub _UploadedFile {
+ my $arg = shift;
+ my $cgi_object = $m->cgi_object;
+ my $fh = $cgi_object->upload($arg) or return undef;
+ my $upload_info = $cgi_object->uploadInfo($fh);
+
+ my $filename = "$fh";
+ $filename =~ s#^.*[\\/]##;
+ binmode($fh);
+
+ return {
+ Value => $filename,
+ LargeContent => do { local $/; scalar <$fh> },
+ ContentType => $upload_info->{'Content-Type'},
+ };
+}
eval "require RT::Interface::Web_Vendor";
die $@ if ($@ && $@ !~ qr{^Can't locate RT/Interface/Web_Vendor.pm});
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Base
+=head2 Base
Returns the current value of Base.
(In the database, Base is stored as varchar(240).)
-=item SetBase VALUE
+=head2 SetBase VALUE
Set Base to VALUE.
=cut
-=item Target
+=head2 Target
Returns the current value of Target.
(In the database, Target is stored as varchar(240).)
-=item SetTarget VALUE
+=head2 SetTarget VALUE
Set Target to VALUE.
=cut
-=item Type
+=head2 Type
Returns the current value of Type.
(In the database, Type is stored as varchar(20).)
-=item SetType VALUE
+=head2 SetType VALUE
Set Type to VALUE.
=cut
-=item LocalTarget
+=head2 LocalTarget
Returns the current value of LocalTarget.
(In the database, LocalTarget is stored as int(11).)
-=item SetLocalTarget VALUE
+=head2 SetLocalTarget VALUE
Set LocalTarget to VALUE.
=cut
-=item LocalBase
+=head2 LocalBase
Returns the current value of LocalBase.
(In the database, LocalBase is stored as int(11).)
-=item SetLocalBase VALUE
+=head2 SetLocalBase VALUE
Set LocalBase to VALUE.
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Base =>
- {read => 1, write => 1, type => 'varchar(240)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 240, is_blob => 0, is_numeric => 0, type => 'varchar(240)', default => ''},
Target =>
- {read => 1, write => 1, type => 'varchar(240)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 240, is_blob => 0, is_numeric => 0, type => 'varchar(240)', default => ''},
Type =>
- {read => 1, write => 1, type => 'varchar(20)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 20, is_blob => 0, is_numeric => 0, type => 'varchar(20)', default => ''},
LocalTarget =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LocalBase =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Link item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Name
+=head2 Name
Returns the current value of Name.
(In the database, Name is stored as varchar(200).)
-=item SetName VALUE
+=head2 SetName VALUE
Set Name to VALUE.
=cut
-=item Description
+=head2 Description
Returns the current value of Description.
(In the database, Description is stored as varchar(255).)
-=item SetDescription VALUE
+=head2 SetDescription VALUE
Set Description to VALUE.
=cut
-=item CorrespondAddress
+=head2 CorrespondAddress
Returns the current value of CorrespondAddress.
(In the database, CorrespondAddress is stored as varchar(120).)
-=item SetCorrespondAddress VALUE
+=head2 SetCorrespondAddress VALUE
Set CorrespondAddress to VALUE.
=cut
-=item CommentAddress
+=head2 CommentAddress
Returns the current value of CommentAddress.
(In the database, CommentAddress is stored as varchar(120).)
-=item SetCommentAddress VALUE
+=head2 SetCommentAddress VALUE
Set CommentAddress to VALUE.
=cut
-=item InitialPriority
+=head2 InitialPriority
Returns the current value of InitialPriority.
(In the database, InitialPriority is stored as int(11).)
-=item SetInitialPriority VALUE
+=head2 SetInitialPriority VALUE
Set InitialPriority to VALUE.
=cut
-=item FinalPriority
+=head2 FinalPriority
Returns the current value of FinalPriority.
(In the database, FinalPriority is stored as int(11).)
-=item SetFinalPriority VALUE
+=head2 SetFinalPriority VALUE
Set FinalPriority to VALUE.
=cut
-=item DefaultDueIn
+=head2 DefaultDueIn
Returns the current value of DefaultDueIn.
(In the database, DefaultDueIn is stored as int(11).)
-=item SetDefaultDueIn VALUE
+=head2 SetDefaultDueIn VALUE
Set DefaultDueIn to VALUE.
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
=cut
-=item Disabled
+=head2 Disabled
Returns the current value of Disabled.
(In the database, Disabled is stored as smallint(6).)
-=item SetDisabled VALUE
+=head2 SetDisabled VALUE
Set Disabled to VALUE.
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Name =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Description =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
CorrespondAddress =>
- {read => 1, write => 1, type => 'varchar(120)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 120, is_blob => 0, is_numeric => 0, type => 'varchar(120)', default => ''},
CommentAddress =>
- {read => 1, write => 1, type => 'varchar(120)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 120, is_blob => 0, is_numeric => 0, type => 'varchar(120)', default => ''},
InitialPriority =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
FinalPriority =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
DefaultDueIn =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Disabled =>
- {read => 1, write => 1, type => 'smallint(6)', default => '0'},
+ {read => 1, write => 1, sql_type => 5, length => 6, is_blob => 0, is_numeric => 1, type => 'smallint(6)', default => '0'},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Queue item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
-# END LICENSE BLOCK
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
=head1 NAME
RT::Record - Base class for RT record objects
package RT::Record;
use RT::Date;
use RT::User;
-
+use RT::Attributes;
use RT::Base;
use DBIx::SearchBuilder::Record::Cachable;
use strict;
-use vars qw/@ISA/;
+use vars qw/@ISA $_TABLE_ATTR/;
@ISA = qw(RT::Base);
sub _Init {
my $self = shift;
+ $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
$self->CurrentUser(@_);
-
}
# }}}
# }}}
+=head2 Delete
+
+Delete this record object from the database.
+
+=cut
+
+sub Delete {
+ my $self = shift;
+ my ($rv) = $self->SUPER::Delete;
+ if ($rv) {
+ return ($rv, $self->loc("Object deleted"));
+ } else {
+
+ return(0, $self->loc("Object could not be deleted"))
+ }
+}
+
+=head2 ObjectTypeStr
+
+Returns a string which is this object's type. The type is the class,
+without the "RT::" prefix.
+
+=begin testing
+
+my $ticket = RT::Ticket->new($RT::SystemUser);
+my $group = RT::Group->new($RT::SystemUser);
+is($ticket->ObjectTypeStr, 'Ticket', "Ticket returns correct typestring");
+is($group->ObjectTypeStr, 'Group', "Group returns correct typestring");
+
+=end testing
+
+=cut
+
+sub ObjectTypeStr {
+ my $self = shift;
+ if (ref($self) =~ /^.*::(\w+)$/) {
+ return $self->loc($1);
+ } else {
+ return $self->loc(ref($self));
+ }
+}
+
+=head2 Attributes
+
+Return this object's attributes as an RT::Attributes object
+
+=cut
+
+sub Attributes {
+ my $self = shift;
+
+ unless ($self->{'attributes'}) {
+ $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
+ $self->{'attributes'}->LimitToObject($self);
+ }
+ return ($self->{'attributes'});
+
+}
+
+
+=head2 AddAttribute { Name, Description, Content }
+
+Adds a new attribute for this object.
+
+=cut
+
+sub AddAttribute {
+ my $self = shift;
+ my %args = ( Name => undef,
+ Description => undef,
+ Content => undef,
+ @_ );
+
+ my $attr = RT::Attribute->new( $self->CurrentUser );
+ my ( $id, $msg ) = $attr->Create(
+ Object => $self,
+ Name => $args{'Name'},
+ Description => $args{'Description'},
+ Content => $args{'Content'} );
+
+
+ # XXX TODO: Why won't RedoSearch work here?
+ $self->Attributes->_DoSearch;
+
+ return ($id, $msg);
+}
+
+
+=head2 SetAttribute { Name, Description, Content }
+
+Like AddAttribute, but replaces all existing attributes with the same Name.
+
+=cut
+
+sub SetAttribute {
+ my $self = shift;
+ my %args = ( Name => undef,
+ Description => undef,
+ Content => undef,
+ @_ );
+
+ my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
+ or return $self->AddAttribute( %args );
+
+ my $AttributeObj = pop( @AttributeObjs );
+ $_->Delete foreach @AttributeObjs;
+
+ $AttributeObj->SetDescription( $args{'Description'} );
+ $AttributeObj->SetContent( $args{'Content'} );
+
+ $self->Attributes->RedoSearch;
+ return 1;
+}
+
+=head2 DeleteAttribute NAME
+
+Deletes all attributes with the matching name for this object.
+
+=cut
+
+sub DeleteAttribute {
+ my $self = shift;
+ my $name = shift;
+ return $self->Attributes->DeleteEntry( Name => $name );
+}
+
+=head2 FirstAttribute NAME
+
+Returns the value of the first attribute with the matching name
+for this object, or C<undef> if no such attributes exist.
+
+=cut
+
+sub FirstAttribute {
+ my $self = shift;
+ my $name = shift;
+ return ($self->Attributes->Named( $name ))[0];
+}
+
+
# {{{ sub _Handle
sub _Handle {
my $self = shift;
# {{{ sub Create
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Takes a PARAMHASH of Column -> Value pairs.
If any Column has a Validate$PARAMNAME subroutine defined and the
my $self = shift;
my %hash = (@_);
+ # We don't want to hang onto this
+ delete $self->{'attributes'};
+
# If this database is case sensitive we need to uncase objects for
# explicit loading
if ( $self->_Handle->CaseSensitive ) {
$newhash{$key} = $hash{$key};
}
else {
- $newhash{ "lower(" . $key . ")" } = lc( $hash{$key} );
+ my ($op, $val, $func);
+ ($key, $op, $val, $func) = $self->_Handle->_MakeClauseCaseInsensitive($key, '=', $hash{$key});
+ $newhash{$key}->{operator} = $op;
+ $newhash{$key}->{value} = $val;
+ $newhash{$key}->{function} = $func;
}
}
# }}} Datehandling
# {{{ sub _Set
+#
sub _Set {
my $self = shift;
$args{'Value'} = 0;
}
- $self->_SetLastUpdated();
- my ( $val, $msg ) = $self->SUPER::_Set(
+ my $old_val = $self->__Value($args{'Field'});
+ $self->_SetLastUpdated();
+ my $ret = $self->SUPER::_Set(
Field => $args{'Field'},
Value => $args{'Value'},
IsSQL => $args{'IsSQL'}
);
+ my ($status, $msg) = $ret->as_array();
+
+ # @values has two values, a status code and a message.
+
+ # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
+ # we want to change the standard "success" message
+ if ($status) {
+ $msg =
+ $self->loc(
+ "[_1] changed from [_2] to [_3]",
+ $args{'Field'},
+ ( $old_val ? "'$old_val'" : $self->loc("(no value)") ),
+ '"' . $self->__Value( $args{'Field'}) . '"'
+ );
+ } else {
+
+ $msg = $self->CurrentUser->loc_fuzzy($msg);
+ }
+ return wantarray ? ($status, $msg) : $ret;
+
}
# }}}
# }}}
+# {{{ sub URI
+
+=head2 URI
+
+Returns this record's URI
+
+=cut
+
+sub URI {
+ my $self = shift;
+ my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
+ return($uri->URIForObject($self));
+}
+
+# }}}
+
+=head2 ValidateName NAME
+
+Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
+
+=cut
+
+sub ValidateName {
+ my $self = shift;
+ my $value = shift;
+ if ($value && $value=~ /^\d+$/) {
+ return(0);
+ } else {
+ return (1);
+ }
+}
+
+
+
+=head2 SQLType attribute
+
+return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
+
+=cut
+
+sub SQLType {
+ my $self = shift;
+ my $field = shift;
+
+ return ($self->_Accessible($field, 'type'));
+
+
+}
require Encode::compat if $] < 5.007001;
require Encode;
+
+
+
sub __Value {
my $self = shift;
my $field = shift;
return('') if ( !defined($value) || $value eq '');
- return Encode::decode_utf8($value) || $value if $args{'decode_utf8'};
+ if( $args{'decode_utf8'} ) {
+ # XXX: is_utf8 check should be here unless Encode bug would be fixed
+ # see http://rt.cpan.org/NoAuth/Bug.html?id=14559
+ return Encode::decode_utf8($value) unless Encode::is_utf8($value);
+ } else {
+ # check is_utf8 here just to be shure
+ return Encode::encode_utf8($value) if Encode::is_utf8($value);
+ }
return $value;
}
sub _CacheConfig {
{
'cache_p' => 1,
- 'fast_update_p' => 1,
'cache_for_sec' => 30,
}
}
-=head2 _DecodeUTF8
- When passed a string will "decode" it int a proper UTF-8 string
+
+sub _BuildTableAttributes {
+ my $self = shift;
+
+ my $attributes;
+ if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
+ $attributes = $self->_CoreAccessible();
+ } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
+ $attributes = $self->_ClassAccessible();
+
+ }
+
+ foreach my $column (%$attributes) {
+ foreach my $attr ( %{ $attributes->{$column} } ) {
+ $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
+ }
+ }
+ if ( UNIVERSAL::can( $self, '_OverlayAccessible' ) ) {
+ $attributes = $self->_OverlayAccessible();
+
+ foreach my $column (%$attributes) {
+ foreach my $attr ( %{ $attributes->{$column} } ) {
+ $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
+ }
+ }
+ }
+ if ( UNIVERSAL::can( $self, '_VendorAccessible' ) ) {
+ $attributes = $self->_VendorAccessible();
+
+ foreach my $column (%$attributes) {
+ foreach my $attr ( %{ $attributes->{$column} } ) {
+ $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
+ }
+ }
+ }
+ if ( UNIVERSAL::can( $self, '_LocalAccessible' ) ) {
+ $attributes = $self->_LocalAccessible();
+
+ foreach my $column (%$attributes) {
+ foreach my $attr ( %{ $attributes->{$column} } ) {
+ $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
+ }
+ }
+ }
+
+}
+
+
+=head2 _ClassAccessible
+
+Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
+DBIx::SearchBuilder::Record
+
+=cut
+
+sub _ClassAccessible {
+ my $self = shift;
+ return $_TABLE_ATTR->{ref($self)};
+}
+
+=head2 _Accessible COLUMN ATTRIBUTE
+
+returns the value of ATTRIBUTE for COLUMN
+
+
+=cut
+
+sub _Accessible {
+ my $self = shift;
+ my $column = shift;
+ my $attribute = lc(shift);
+ return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
+ return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
+
+}
+
+=head2 _EncodeLOB BODY MIME_TYPE
+
+Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
+
+=cut
+
+sub _EncodeLOB {
+ my $self = shift;
+ my $Body = shift;
+ my $MIMEType = shift;
+
+ my $ContentEncoding = 'none';
+
+ #get the max attachment length from RT
+ my $MaxSize = $RT::MaxAttachmentSize;
+
+ #if the current attachment contains nulls and the
+ #database doesn't support embedded nulls
+
+ if ( $RT::AlwaysUseBase64 or
+ ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
+
+ # set a flag telling us to mimencode the attachment
+ $ContentEncoding = 'base64';
+
+ #cut the max attchment size by 25% (for mime-encoding overhead.
+ $RT::Logger->debug("Max size is $MaxSize\n");
+ $MaxSize = $MaxSize * 3 / 4;
+ # Some databases (postgres) can't handle non-utf8 data
+ } elsif ( !$RT::Handle->BinarySafeBLOBs
+ && $MIMEType !~ /text\/plain/gi
+ && !Encode::is_utf8( $Body, 1 ) ) {
+ $ContentEncoding = 'quoted-printable';
+ }
+
+ #if the attachment is larger than the maximum size
+ if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
+
+ # if we're supposed to truncate large attachments
+ if ($RT::TruncateLongAttachments) {
+
+ # truncate the attachment to that length.
+ $Body = substr( $Body, 0, $MaxSize );
+
+ }
+
+ # elsif we're supposed to drop large attachments on the floor,
+ elsif ($RT::DropLongAttachments) {
+
+ # drop the attachment on the floor
+ $RT::Logger->info( "$self: Dropped an attachment of size " . length($Body) . "\n" . "It started: " . substr( $Body, 0, 60 ) . "\n" );
+ return ("none", "Large attachment dropped" );
+ }
+ }
+
+ # if we need to mimencode the attachment
+ if ( $ContentEncoding eq 'base64' ) {
+
+ # base64 encode the attachment
+ Encode::_utf8_off($Body);
+ $Body = MIME::Base64::encode_base64($Body);
+
+ } elsif ($ContentEncoding eq 'quoted-printable') {
+ Encode::_utf8_off($Body);
+ $Body = MIME::QuotedPrint::encode($Body);
+ }
+
+
+ return ($ContentEncoding, $Body);
+
+}
+
+sub _DecodeLOB {
+ my $self = shift;
+ my $ContentType = shift;
+ my $ContentEncoding = shift;
+ my $Content = shift;
+
+ if ( $ContentEncoding eq 'base64' ) {
+ $Content = MIME::Base64::decode_base64($Content);
+ }
+ elsif ( $ContentEncoding eq 'quoted-printable' ) {
+ $Content = MIME::QuotedPrint::decode($Content);
+ }
+ elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
+ return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
+ }
+ if ( $ContentType eq 'text/plain' ) {
+ $Content = Encode::decode_utf8($Content) unless Encode::is_utf8($Content);
+ }
+ return ($Content);
+}
+
+# {{{ LINKDIRMAP
+# A helper table for links mapping to make it easier
+# to build and parse links between tickets
+
+use vars '%LINKDIRMAP';
+
+%LINKDIRMAP = (
+ MemberOf => { Base => 'MemberOf',
+ Target => 'HasMember', },
+ RefersTo => { Base => 'RefersTo',
+ Target => 'ReferredToBy', },
+ DependsOn => { Base => 'DependsOn',
+ Target => 'DependedOnBy', },
+ MergedInto => { Base => 'MergedInto',
+ Target => 'MergedInto', },
+
+);
+
+sub Update {
+ my $self = shift;
+
+ my %args = (
+ ARGSRef => undef,
+ AttributesRef => undef,
+ AttributePrefix => undef,
+ @_
+ );
+
+ my $attributes = $args{'AttributesRef'};
+ my $ARGSRef = $args{'ARGSRef'};
+ my @results;
+
+ foreach my $attribute (@$attributes) {
+ my $value;
+ if ( defined $ARGSRef->{$attribute} ) {
+ $value = $ARGSRef->{$attribute};
+ }
+ elsif (
+ defined( $args{'AttributePrefix'} )
+ && defined(
+ $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
+ )
+ ) {
+ $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
+
+ }
+ else {
+ next;
+ }
+
+ $value =~ s/\r\n/\n/gs;
+
+
+ # If Queue is 'General', we want to resolve the queue name for
+ # the object.
+
+ # This is in an eval block because $object might not exist.
+ # and might not have a Name method. But "can" won't find autoloaded
+ # items. If it fails, we don't care
+ eval {
+ my $object = $attribute . "Obj";
+ next if ($self->$object->Name eq $value);
+ };
+ next if ( $value eq $self->$attribute() );
+ my $method = "Set$attribute";
+ my ( $code, $msg ) = $self->$method($value);
+ my ($prefix) = ref($self) =~ /RT::(\w+)/;
+
+ # Default to $id, but use name if we can get it.
+ my $label = $self->id;
+ $label = $self->Name if (UNIVERSAL::can($self,'Name'));
+ push @results, $self->loc( "$prefix [_1]", $label ) . ': '. $msg;
+
+=for loc
+
+ "[_1] could not be set to [_2].", # loc
+ "That is already the current value", # loc
+ "No value sent to _Set!\n", # loc
+ "Illegal value for [_1]", # loc
+ "The new value has been set.", # loc
+ "No column specified", # loc
+ "Immutable field", # loc
+ "Nonexistant field?", # loc
+ "Invalid data", # loc
+ "Couldn't find row", # loc
+ "Missing a primary key?: [_1]", # loc
+ "Found Object", # loc
+
+=cut
+
+ }
+
+ return @results;
+}
+
+# {{{ Routines dealing with Links
+
+# {{{ Link Collections
+
+# {{{ sub Members
+
+=head2 Members
+
+ This returns an RT::Links object which references all the tickets
+which are 'MembersOf' this ticket
+
+=cut
+
+sub Members {
+ my $self = shift;
+ return ( $self->_Links( 'Target', 'MemberOf' ) );
+}
+
+# }}}
+
+# {{{ sub MemberOf
+
+=head2 MemberOf
+
+ This returns an RT::Links object which references all the tickets that this
+ticket is a 'MemberOf'
+
+=cut
+
+sub MemberOf {
+ my $self = shift;
+ return ( $self->_Links( 'Base', 'MemberOf' ) );
+}
+
+# }}}
+
+# {{{ RefersTo
+
+=head2 RefersTo
+
+ This returns an RT::Links object which shows all references for which this ticket is a base
+
+=cut
+
+sub RefersTo {
+ my $self = shift;
+ return ( $self->_Links( 'Base', 'RefersTo' ) );
+}
+
+# }}}
+
+# {{{ ReferredToBy
+
+=head2 ReferredToBy
+
+ This returns an RT::Links object which shows all references for which this ticket is a target
+
+=cut
+
+sub ReferredToBy {
+ my $self = shift;
+ return ( $self->_Links( 'Target', 'RefersTo' ) );
+}
+
+# }}}
+
+# {{{ DependedOnBy
+
+=head2 DependedOnBy
+
+ This returns an RT::Links object which references all the tickets that depend on this one
=cut
+sub DependedOnBy {
+ my $self = shift;
+ return ( $self->_Links( 'Target', 'DependsOn' ) );
+}
+
+# }}}
+
+
+
+=head2 HasUnresolvedDependencies
+
+ Takes a paramhash of Type (default to '__any'). Returns true if
+$self->UnresolvedDependencies returns an object with one or more members
+of that type. Returns false otherwise
+
+
+=begin testing
+
+my $t1 = RT::Ticket->new($RT::SystemUser);
+my ($id, $trans, $msg) = $t1->Create(Subject => 'DepTest1', Queue => 'general');
+ok($id, "Created dep test 1 - $msg");
+
+my $t2 = RT::Ticket->new($RT::SystemUser);
+my ($id2, $trans, $msg2) = $t2->Create(Subject => 'DepTest2', Queue => 'general');
+ok($id2, "Created dep test 2 - $msg2");
+my $t3 = RT::Ticket->new($RT::SystemUser);
+my ($id3, $trans, $msg3) = $t3->Create(Subject => 'DepTest3', Queue => 'general', Type => 'approval');
+ok($id3, "Created dep test 3 - $msg3");
+my ($addid, $addmsg);
+ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t2->id));
+ok ($addid, $addmsg);
+ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t3->id));
+
+ok ($addid, $addmsg);
+my $link = RT::Link->new($RT::SystemUser);
+my ($rv, $msg) = $link->Load($addid);
+ok ($rv, $msg);
+ok ($link->LocalTarget == $t3->id, "Link LocalTarget is correct");
+ok ($link->LocalBase == $t1->id, "Link LocalBase is correct");
+
+ok ($t1->HasUnresolvedDependencies, "Ticket ".$t1->Id." has unresolved deps");
+ok (!$t1->HasUnresolvedDependencies( Type => 'blah' ), "Ticket ".$t1->Id." has no unresolved blahs");
+ok ($t1->HasUnresolvedDependencies( Type => 'approval' ), "Ticket ".$t1->Id." has unresolved approvals");
+ok (!$t2->HasUnresolvedDependencies, "Ticket ".$t2->Id." has no unresolved deps");
+;
+
+my ($rid, $rmsg)= $t1->Resolve();
+ok(!$rid, $rmsg);
+my ($rid2, $rmsg2) = $t2->Resolve();
+ok ($rid2, $rmsg2);
+($rid, $rmsg)= $t1->Resolve();
+ok(!$rid, $rmsg);
+my ($rid3,$rmsg3) = $t3->Resolve;
+ok ($rid3,$rmsg3);
+($rid, $rmsg)= $t1->Resolve();
+ok($rid, $rmsg);
+
+
+=end testing
+
+=cut
+
+sub HasUnresolvedDependencies {
+ my $self = shift;
+ my %args = (
+ Type => undef,
+ @_
+ );
+
+ my $deps = $self->UnresolvedDependencies;
+
+ if ($args{Type}) {
+ $deps->Limit( FIELD => 'Type',
+ OPERATOR => '=',
+ VALUE => $args{Type});
+ }
+ else {
+ $deps->IgnoreType;
+ }
+
+ if ($deps->Count > 0) {
+ return 1;
+ }
+ else {
+ return (undef);
+ }
+}
+
+
+# {{{ UnresolvedDependencies
+
+=head2 UnresolvedDependencies
+
+Returns an RT::Tickets object of tickets which this ticket depends on
+and which have a status of new, open or stalled. (That list comes from
+RT::Queue->ActiveStatusArray
+
+=cut
+
+
+sub UnresolvedDependencies {
+ my $self = shift;
+ my $deps = RT::Tickets->new($self->CurrentUser);
+
+ my @live_statuses = RT::Queue->ActiveStatusArray();
+ foreach my $status (@live_statuses) {
+ $deps->LimitStatus(VALUE => $status);
+ }
+ $deps->LimitDependedOnBy($self->Id);
+
+ return($deps);
+
+}
+
+# }}}
+
+# {{{ AllDependedOnBy
+
+=head2 AllDependedOnBy
+
+Returns an array of RT::Ticket objects which (directly or indirectly)
+depends on this ticket; takes an optional 'Type' argument in the param
+hash, which will limit returned tickets to that type, as well as cause
+tickets with that type to serve as 'leaf' nodes that stops the recursive
+dependency search.
+
+=cut
+
+sub AllDependedOnBy {
+ my $self = shift;
+ my $dep = $self->DependedOnBy;
+ my %args = (
+ Type => undef,
+ _found => {},
+ _top => 1,
+ @_
+ );
+
+ while (my $link = $dep->Next()) {
+ next unless ($link->BaseURI->IsLocal());
+ next if $args{_found}{$link->BaseObj->Id};
+
+ if (!$args{Type}) {
+ $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
+ $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
+ }
+ elsif ($link->BaseObj->Type eq $args{Type}) {
+ $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
+ }
+ else {
+ $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
+ }
+ }
+
+ if ($args{_top}) {
+ return map { $args{_found}{$_} } sort keys %{$args{_found}};
+ }
+ else {
+ return 1;
+ }
+}
+
+# }}}
+
+# {{{ DependsOn
+
+=head2 DependsOn
+
+ This returns an RT::Links object which references all the tickets that this ticket depends on
+
+=cut
+
+sub DependsOn {
+ my $self = shift;
+ return ( $self->_Links( 'Base', 'DependsOn' ) );
+}
+
+# }}}
+
+
+
+
+# {{{ sub _Links
+
+=head2 Links DIRECTION TYPE
+
+return links to/from this object.
+
+=cut
+
+*Links = \&_Links;
+
+sub _Links {
+ my $self = shift;
+
+ #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
+ #tobias meant by $f
+ my $field = shift;
+ my $type = shift || "";
+
+ unless ( $self->{"$field$type"} ) {
+ $self->{"$field$type"} = new RT::Links( $self->CurrentUser );
+ # at least to myself
+ $self->{"$field$type"}->Limit( FIELD => $field,
+ VALUE => $self->URI,
+ ENTRYAGGREGATOR => 'OR' );
+ $self->{"$field$type"}->Limit( FIELD => 'Type',
+ VALUE => $type )
+ if ($type);
+ }
+ return ( $self->{"$field$type"} );
+}
+
+# }}}
+
+# }}}
+
+# {{{ sub _AddLink
+
+=head2 _AddLink
+
+Takes a paramhash of Type and one of Base or Target. Adds that link to this ticket.
+
+
+=cut
+
+
+sub _AddLink {
+ my $self = shift;
+ my %args = ( Target => '',
+ Base => '',
+ Type => '',
+ Silent => undef,
+ @_ );
+
+
+ # Remote_link is the URI of the object that is not this ticket
+ my $remote_link;
+ my $direction;
+
+ if ( $args{'Base'} and $args{'Target'} ) {
+ $RT::Logger->debug( "$self tried to create a link. both base and target were specified\n" );
+ return ( 0, $self->loc("Can't specifiy both base and target") );
+ }
+ elsif ( $args{'Base'} ) {
+ $args{'Target'} = $self->URI();
+ my $class = ref($self);
+ $remote_link = $args{'Base'};
+ $direction = 'Target';
+ }
+ elsif ( $args{'Target'} ) {
+ $args{'Base'} = $self->URI();
+ my $class = ref($self);
+ $remote_link = $args{'Target'};
+ $direction = 'Base';
+ }
+ else {
+ return ( 0, $self->loc('Either base or target must be specified') );
+ }
+
+ # {{{ Check if the link already exists - we don't want duplicates
+ use RT::Link;
+ my $old_link = RT::Link->new( $self->CurrentUser );
+ $old_link->LoadByParams( Base => $args{'Base'},
+ Type => $args{'Type'},
+ Target => $args{'Target'} );
+ if ( $old_link->Id ) {
+ $RT::Logger->debug("$self Somebody tried to duplicate a link");
+ return ( $old_link->id, $self->loc("Link already exists") );
+ }
+
+ # }}}
+
+
+ # Storing the link in the DB.
+ my $link = RT::Link->new( $self->CurrentUser );
+ my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
+ Base => $args{Base},
+ Type => $args{Type} );
+
+ unless ($linkid) {
+ $RT::Logger->error("Link could not be created: ".$linkmsg);
+ return ( 0, $self->loc("Link could not be created") );
+ }
+
+ my $TransString =
+ "Record $args{'Base'} $args{Type} record $args{'Target'}.";
+
+ return ( $linkid, $self->loc( "Link created ([_1])", $TransString ) );
+}
+
+# }}}
+
+# {{{ sub _DeleteLink
+
+=head2 _DeleteLink
+
+Delete a link. takes a paramhash of Base, Target and Type.
+Either Base or Target must be null. The null value will
+be replaced with this ticket\'s id
+
+=cut
+
+sub _DeleteLink {
+ my $self = shift;
+ my %args = (
+ Base => undef,
+ Target => undef,
+ Type => undef,
+ @_
+ );
+
+ #we want one of base and target. we don't care which
+ #but we only want _one_
+
+ my $direction;
+ my $remote_link;
+
+ if ( $args{'Base'} and $args{'Target'} ) {
+ $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target\n");
+ return ( 0, $self->loc("Can't specifiy both base and target") );
+ }
+ elsif ( $args{'Base'} ) {
+ $args{'Target'} = $self->URI();
+ $remote_link = $args{'Base'};
+ $direction = 'Target';
+ }
+ elsif ( $args{'Target'} ) {
+ $args{'Base'} = $self->URI();
+ $remote_link = $args{'Target'};
+ $direction='Base';
+ }
+ else {
+ $RT::Logger->debug("$self: Base or Target must be specified\n");
+ return ( 0, $self->loc('Either base or target must be specified') );
+ }
+
+ my $link = new RT::Link( $self->CurrentUser );
+ $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} . "\n" );
+
+
+ $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=> $args{'Target'} );
+ #it's a real link.
+ if ( $link->id ) {
+
+ my $linkid = $link->id;
+ $link->Delete();
+
+ my $TransString = "Record $args{'Base'} no longer $args{Type} record $args{'Target'}.";
+ return ( 1, $self->loc("Link deleted ([_1])", $TransString));
+ }
+
+ #if it's not a link we can find
+ else {
+ $RT::Logger->debug("Couldn't find that link\n");
+ return ( 0, $self->loc("Link not found") );
+ }
+}
+
+# }}}
+
+# }}}
+
+# {{{ Routines dealing with transactions
+
+# {{{ sub _NewTransaction
+
+=head2 _NewTransaction PARAMHASH
+
+Private function to create a new RT::Transaction object for this ticket update
+
+=cut
+
+sub _NewTransaction {
+ my $self = shift;
+ my %args = (
+ TimeTaken => undef,
+ Type => undef,
+ OldValue => undef,
+ NewValue => undef,
+ OldReference => undef,
+ NewReference => undef,
+ ReferenceType => undef,
+ Data => undef,
+ Field => undef,
+ MIMEObj => undef,
+ ActivateScrips => 1,
+ CommitScrips => 1,
+ @_
+ );
+
+ my $old_ref = $args{'OldReference'};
+ my $new_ref = $args{'NewReference'};
+ my $ref_type = $args{'ReferenceType'};
+ if ($old_ref or $new_ref) {
+ $ref_type ||= ref($old_ref) || ref($new_ref);
+ if (!$ref_type) {
+ $RT::Logger->error("Reference type not specified for transaction");
+ return;
+ }
+ $old_ref = $old_ref->Id if ref($old_ref);
+ $new_ref = $new_ref->Id if ref($new_ref);
+ }
+
+ require RT::Transaction;
+ my $trans = new RT::Transaction( $self->CurrentUser );
+ my ( $transaction, $msg ) = $trans->Create(
+ ObjectId => $self->Id,
+ ObjectType => ref($self),
+ TimeTaken => $args{'TimeTaken'},
+ Type => $args{'Type'},
+ Data => $args{'Data'},
+ Field => $args{'Field'},
+ NewValue => $args{'NewValue'},
+ OldValue => $args{'OldValue'},
+ NewReference => $new_ref,
+ OldReference => $old_ref,
+ ReferenceType => $ref_type,
+ MIMEObj => $args{'MIMEObj'},
+ ActivateScrips => $args{'ActivateScrips'},
+ CommitScrips => $args{'CommitScrips'},
+ );
+
+ # Rationalize the object since we may have done things to it during the caching.
+ $self->Load($self->Id);
+
+ $RT::Logger->warning($msg) unless $transaction;
+
+ $self->_SetLastUpdated;
+
+ if ( defined $args{'TimeTaken'} ) {
+ $self->_UpdateTimeTaken( $args{'TimeTaken'} );
+ }
+ if ( $RT::UseTransactionBatch and $transaction ) {
+ push @{$self->{_TransactionBatch}}, $trans;
+ }
+ return ( $transaction, $msg, $trans );
+}
+
+# }}}
+
+# {{{ sub Transactions
+
+=head2 Transactions
+
+ Returns an RT::Transactions object of all transactions on this record object
+
+=cut
+
+sub Transactions {
+ my $self = shift;
+
+ use RT::Transactions;
+ my $transactions = RT::Transactions->new( $self->CurrentUser );
+
+ #If the user has no rights, return an empty object
+ $transactions->Limit(
+ FIELD => 'ObjectId',
+ VALUE => $self->id,
+ );
+ $transactions->Limit(
+ FIELD => 'ObjectType',
+ VALUE => ref($self),
+ );
+
+ return ($transactions);
+}
+
+# }}}
+# }}}
+#
+# {{{ Routines dealing with custom fields
+
+sub CustomFields {
+ my $self = shift;
+ my $cfs = RT::CustomFields->new( $self->CurrentUser );
+
+ # XXX handle multiple types properly
+ $cfs->LimitToLookupType( $self->CustomFieldLookupType );
+ $cfs->LimitToGlobalOrObjectId(
+ $self->_LookupId( $self->CustomFieldLookupType ) );
+
+ return $cfs;
+}
+
+# TODO: This _only_ works for RT::Class classes. it doesn't work, for example, for RT::FM classes.
+
+sub _LookupId {
+ my $self = shift;
+ my $lookup = shift;
+ my @classes = ($lookup =~ /RT::(\w+)-/g);
+
+ my $object = $self;
+ foreach my $class (reverse @classes) {
+ my $method = "${class}Obj";
+ $object = $object->$method;
+ }
+
+ return $object->Id;
+}
+
+
+=head2 CustomFieldLookupType
+
+Returns the path RT uses to figure out which custom fields apply to this object.
+
+=cut
+
+sub CustomFieldLookupType {
+ my $self = shift;
+ return ref($self);
+}
+
+#TODO Deprecated API. Destroy in 3.6
+sub _LookupTypes {
+ my $self = shift;
+ $RT::Logger->warning("_LookupTypes call is deprecated at (". join(":",caller)."). Replace with CustomFieldLookupType");
+
+ return($self->CustomFieldLookupType);
+
+}
+
+# {{{ AddCustomFieldValue
+
+=head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
+
+VALUE should be a string.
+FIELD can be a CustomField object OR a CustomField ID.
+
+
+Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
+deletes the old value.
+If VALUE is not a valid value for the custom field, returns
+(0, 'Error message' ) otherwise, returns (1, 'Success Message')
+
+=cut
+
+sub AddCustomFieldValue {
+ my $self = shift;
+ $self->_AddCustomFieldValue(@_);
+}
+
+sub _AddCustomFieldValue {
+ my $self = shift;
+ my %args = (
+ Field => undef,
+ Value => undef,
+ RecordTransaction => 1,
+ @_
+ );
+
+ my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
+
+ unless ( $cf->Id ) {
+ return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
+ }
+
+ my $OCFs = $self->CustomFields;
+ $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
+ unless ( $OCFs->Count ) {
+ return (
+ 0,
+ $self->loc(
+ "Custom field [_1] does not apply to this object",
+ $args{'Field'}
+ )
+ );
+ }
+ # Load up a ObjectCustomFieldValues object for this custom field and this ticket
+ my $values = $cf->ValuesForObject($self);
+
+ unless ( $cf->ValidateValue( $args{'Value'} ) ) {
+ return ( 0, $self->loc("Invalid value for custom field") );
+ }
+
+ # If the custom field only accepts a certain # of values, delete the existing
+ # value and record a "changed from foo to bar" transaction
+ unless ( $cf->UnlimitedValues) {
+
+ # We need to whack any old values here. In most cases, the custom field should
+ # only have one value to delete. In the pathalogical case, this custom field
+ # used to be a multiple and we have many values to whack....
+ my $cf_values = $values->Count;
+
+ if ( $cf_values > $cf->MaxValues ) {
+ my $i = 0; #We want to delete all but the max we can currently have , so we can then
+ # execute the same code to "change" the value from old to new
+ while ( my $value = $values->Next ) {
+ $i++;
+ if ( $i < $cf_values ) {
+ my ( $val, $msg ) = $cf->DeleteValueForObject(
+ Object => $self,
+ Content => $value->Content
+ );
+ unless ($val) {
+ return ( 0, $msg );
+ }
+ my ( $TransactionId, $Msg, $TransactionObj ) =
+ $self->_NewTransaction(
+ Type => 'CustomField',
+ Field => $cf->Id,
+ OldReference => $value,
+ );
+ }
+ }
+ }
+
+ my ( $old_value, $old_content );
+ if ( $old_value = $cf->ValuesForObject($self)->First ) {
+ $old_content = $old_value->Content();
+ return (1) if( $old_content eq $args{'Value'} && $old_value->LargeContent eq $args{'LargeContent'});;
+ }
+
+ my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
+ Object => $self,
+ Content => $args{'Value'},
+ LargeContent => $args{'LargeContent'},
+ ContentType => $args{'ContentType'},
+ );
+
+ unless ($new_value_id) {
+ return ( 0, $self->loc( "Could not add new custom field value. [_1] ",, $value_msg));
+ }
+
+ my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
+ $new_value->Load($new_value_id);
+
+ # now that adding the new value was successful, delete the old one
+ if ($old_value) {
+ my ( $val, $msg ) = $old_value->Delete();
+ unless ($val) {
+ return ( 0, $msg );
+ }
+ }
+
+ if ( $args{'RecordTransaction'} ) {
+ my ( $TransactionId, $Msg, $TransactionObj ) =
+ $self->_NewTransaction(
+ Type => 'CustomField',
+ Field => $cf->Id,
+ OldReference => $old_value,
+ NewReference => $new_value,
+ );
+ }
+
+ if ( $old_value eq '' ) {
+ return ( 1, $self->loc( "[_1] [_2] added", $cf->Name, $new_value->Content ));
+ }
+ elsif ( $new_value->Content eq '' ) {
+ return ( 1,
+ $self->loc( "[_1] [_2] deleted", $cf->Name, $old_value->Content ) );
+ }
+ else {
+ return ( 1, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_value->Content));
+ }
+
+ }
+
+ # otherwise, just add a new value and record "new value added"
+ else {
+ my ($new_value_id) = $cf->AddValueForObject(
+ Object => $self,
+ Content => $args{'Value'},
+ LargeContent => $args{'LargeContent'},
+ ContentType => $args{'ContentType'},
+ );
+
+ unless ($new_value_id) {
+ return ( 0, $self->loc("Could not add new custom field value. ") );
+ }
+ if ( $args{'RecordTransaction'} ) {
+ my ( $TransactionId, $Msg, $TransactionObj ) =
+ $self->_NewTransaction(
+ Type => 'CustomField',
+ Field => $cf->Id,
+ NewReference => $new_value_id,
+ ReferenceType => 'RT::ObjectCustomFieldValue',
+ );
+ unless ($TransactionId) {
+ return ( 0,
+ $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
+ }
+ }
+ return ( 1, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name));
+ }
+
+}
+
+# }}}
+
+# {{{ DeleteCustomFieldValue
+
+=head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
+
+Deletes VALUE as a value of CustomField FIELD.
+
+VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
+
+If VALUE is not a valid value for the custom field, returns
+(0, 'Error message' ) otherwise, returns (1, 'Success Message')
+
+=cut
+
+sub DeleteCustomFieldValue {
+ my $self = shift;
+ my %args = (
+ Field => undef,
+ Value => undef,
+ ValueId => undef,
+ @_
+ );
+
+ my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
+
+ unless ( $cf->Id ) {
+ return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
+ }
+ my ( $val, $msg ) = $cf->DeleteValueForObject(
+ Object => $self,
+ Id => $args{'ValueId'},
+ Content => $args{'Value'},
+ );
+ unless ($val) {
+ return ( 0, $msg );
+ }
+ my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
+ Type => 'CustomField',
+ Field => $cf->Id,
+ OldReference => $val,
+ ReferenceType => 'RT::ObjectCustomFieldValue',
+ );
+ unless ($TransactionId) {
+ return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
+ }
+
+ return (
+ $TransactionId,
+ $self->loc(
+ "[_1] is no longer a value for custom field [_2]",
+ $TransactionObj->OldValue, $cf->Name
+ )
+ );
+}
+
+# }}}
+
+# {{{ FirstCustomFieldValue
+
+=head2 FirstCustomFieldValue FIELD
+
+Return the content of the first value of CustomField FIELD for this ticket
+Takes a field id or name
+
+=cut
+
+sub FirstCustomFieldValue {
+ my $self = shift;
+ my $field = shift;
+ my $values = $self->CustomFieldValues($field);
+ if ($values->First) {
+ return $values->First->Content;
+ } else {
+ return undef;
+ }
+
+}
+
+
+
+# {{{ CustomFieldValues
+
+=head2 CustomFieldValues FIELD
+
+Return a ObjectCustomFieldValues object of all values of the CustomField whose
+id or Name is FIELD for this record.
+
+Returns an RT::ObjectCustomFieldValues object
+
+=cut
+
+sub CustomFieldValues {
+ my $self = shift;
+ my $field = shift;
+
+ if ($field) {
+ my $cf = $self->LoadCustomFieldByIdentifier($field);
+
+ # we were asked to search on a custom field we couldn't fine
+ unless ( $cf->id ) {
+ return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
+ }
+ return ( $cf->ValuesForObject($self) );
+ }
+
+ # we're not limiting to a specific custom field;
+ my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
+ $ocfs->LimitToObject($self);
+ return $ocfs;
+
+}
+
+=head2 CustomField IDENTIFER
+
+Find the custom field has id or name IDENTIFIER for this object.
+
+If no valid field is found, returns an empty RT::CustomField object.
+
+=cut
+
+sub LoadCustomFieldByIdentifier {
+ my $self = shift;
+ my $field = shift;
+
+ my $cf = RT::CustomField->new($self->CurrentUser);
+
+ if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
+ $cf->LoadById( $field->id );
+ }
+ elsif ($field =~ /^\d+$/) {
+ $cf = RT::CustomField->new($self->CurrentUser);
+ $cf->Load($field);
+ } else {
+
+ my $cfs = $self->CustomFields($self->CurrentUser);
+ $cfs->Limit(FIELD => 'Name', VALUE => $field);
+ $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
+ }
+ return $cf;
+}
+
+
+# }}}
+
+# }}}
+
+# }}}
+
+sub BasicColumns {
+}
+
eval "require RT::Record_Vendor";
die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Vendor.pm});
eval "require RT::Record_Local";
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Description
+=head2 Description
Returns the current value of Description.
(In the database, Description is stored as varchar(255).)
-=item SetDescription VALUE
+=head2 SetDescription VALUE
Set Description to VALUE.
=cut
-=item ScripCondition
+=head2 ScripCondition
Returns the current value of ScripCondition.
(In the database, ScripCondition is stored as int(11).)
-=item SetScripCondition VALUE
+=head2 SetScripCondition VALUE
Set ScripCondition to VALUE.
=cut
-=item ScripConditionObj
+=head2 ScripConditionObj
Returns the ScripCondition Object which has the id returned by ScripCondition
return($ScripCondition);
}
-=item ScripAction
+=head2 ScripAction
Returns the current value of ScripAction.
(In the database, ScripAction is stored as int(11).)
-=item SetScripAction VALUE
+=head2 SetScripAction VALUE
Set ScripAction to VALUE.
=cut
-=item ScripActionObj
+=head2 ScripActionObj
Returns the ScripAction Object which has the id returned by ScripAction
return($ScripAction);
}
-=item ConditionRules
+=head2 ConditionRules
Returns the current value of ConditionRules.
(In the database, ConditionRules is stored as text.)
-=item SetConditionRules VALUE
+=head2 SetConditionRules VALUE
Set ConditionRules to VALUE.
=cut
-=item ActionRules
+=head2 ActionRules
Returns the current value of ActionRules.
(In the database, ActionRules is stored as text.)
-=item SetActionRules VALUE
+=head2 SetActionRules VALUE
Set ActionRules to VALUE.
=cut
-=item CustomIsApplicableCode
+=head2 CustomIsApplicableCode
Returns the current value of CustomIsApplicableCode.
(In the database, CustomIsApplicableCode is stored as text.)
-=item SetCustomIsApplicableCode VALUE
+=head2 SetCustomIsApplicableCode VALUE
Set CustomIsApplicableCode to VALUE.
=cut
-=item CustomPrepareCode
+=head2 CustomPrepareCode
Returns the current value of CustomPrepareCode.
(In the database, CustomPrepareCode is stored as text.)
-=item SetCustomPrepareCode VALUE
+=head2 SetCustomPrepareCode VALUE
Set CustomPrepareCode to VALUE.
=cut
-=item CustomCommitCode
+=head2 CustomCommitCode
Returns the current value of CustomCommitCode.
(In the database, CustomCommitCode is stored as text.)
-=item SetCustomCommitCode VALUE
+=head2 SetCustomCommitCode VALUE
Set CustomCommitCode to VALUE.
=cut
-=item Stage
+=head2 Stage
Returns the current value of Stage.
(In the database, Stage is stored as varchar(32).)
-=item SetStage VALUE
+=head2 SetStage VALUE
Set Stage to VALUE.
=cut
-=item Queue
+=head2 Queue
Returns the current value of Queue.
(In the database, Queue is stored as int(11).)
-=item SetQueue VALUE
+=head2 SetQueue VALUE
Set Queue to VALUE.
=cut
-=item QueueObj
+=head2 QueueObj
Returns the Queue Object which has the id returned by Queue
return($Queue);
}
-=item Template
+=head2 Template
Returns the current value of Template.
(In the database, Template is stored as int(11).)
-=item SetTemplate VALUE
+=head2 SetTemplate VALUE
Set Template to VALUE.
=cut
-=item TemplateObj
+=head2 TemplateObj
Returns the Template Object which has the id returned by Template
return($Template);
}
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Description =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
ScripCondition =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
ScripAction =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
ConditionRules =>
- {read => 1, write => 1, type => 'text', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''},
ActionRules =>
- {read => 1, write => 1, type => 'text', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''},
CustomIsApplicableCode =>
- {read => 1, write => 1, type => 'text', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''},
CustomPrepareCode =>
- {read => 1, write => 1, type => 'text', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''},
CustomCommitCode =>
- {read => 1, write => 1, type => 'text', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''},
Stage =>
- {read => 1, write => 1, type => 'varchar(32)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 32, is_blob => 0, is_numeric => 0, type => 'varchar(32)', default => ''},
Queue =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Template =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Name
+=head2 Name
Returns the current value of Name.
(In the database, Name is stored as varchar(200).)
-=item SetName VALUE
+=head2 SetName VALUE
Set Name to VALUE.
=cut
-=item Description
+=head2 Description
Returns the current value of Description.
(In the database, Description is stored as varchar(255).)
-=item SetDescription VALUE
+=head2 SetDescription VALUE
Set Description to VALUE.
=cut
-=item ExecModule
+=head2 ExecModule
Returns the current value of ExecModule.
(In the database, ExecModule is stored as varchar(60).)
-=item SetExecModule VALUE
+=head2 SetExecModule VALUE
Set ExecModule to VALUE.
=cut
-=item Argument
+=head2 Argument
Returns the current value of Argument.
(In the database, Argument is stored as varchar(255).)
-=item SetArgument VALUE
+=head2 SetArgument VALUE
Set Argument to VALUE.
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Name =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Description =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
ExecModule =>
- {read => 1, write => 1, type => 'varchar(60)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 60, is_blob => 0, is_numeric => 0, type => 'varchar(60)', default => ''},
Argument =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::ScripAction item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Name
+=head2 Name
Returns the current value of Name.
(In the database, Name is stored as varchar(200).)
-=item SetName VALUE
+=head2 SetName VALUE
Set Name to VALUE.
=cut
-=item Description
+=head2 Description
Returns the current value of Description.
(In the database, Description is stored as varchar(255).)
-=item SetDescription VALUE
+=head2 SetDescription VALUE
Set Description to VALUE.
=cut
-=item ExecModule
+=head2 ExecModule
Returns the current value of ExecModule.
(In the database, ExecModule is stored as varchar(60).)
-=item SetExecModule VALUE
+=head2 SetExecModule VALUE
Set ExecModule to VALUE.
=cut
-=item Argument
+=head2 Argument
Returns the current value of Argument.
(In the database, Argument is stored as varchar(255).)
-=item SetArgument VALUE
+=head2 SetArgument VALUE
Set Argument to VALUE.
=cut
-=item ApplicableTransTypes
+=head2 ApplicableTransTypes
Returns the current value of ApplicableTransTypes.
(In the database, ApplicableTransTypes is stored as varchar(60).)
-=item SetApplicableTransTypes VALUE
+=head2 SetApplicableTransTypes VALUE
Set ApplicableTransTypes to VALUE.
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Name =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Description =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
ExecModule =>
- {read => 1, write => 1, type => 'varchar(60)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 60, is_blob => 0, is_numeric => 0, type => 'varchar(60)', default => ''},
Argument =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
ApplicableTransTypes =>
- {read => 1, write => 1, type => 'varchar(60)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 60, is_blob => 0, is_numeric => 0, type => 'varchar(60)', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::ScripCondition item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Scrip item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Queue
+=head2 Queue
Returns the current value of Queue.
(In the database, Queue is stored as int(11).)
-=item SetQueue VALUE
+=head2 SetQueue VALUE
Set Queue to VALUE.
=cut
-=item QueueObj
+=head2 QueueObj
Returns the Queue Object which has the id returned by Queue
return($Queue);
}
-=item Name
+=head2 Name
Returns the current value of Name.
(In the database, Name is stored as varchar(200).)
-=item SetName VALUE
+=head2 SetName VALUE
Set Name to VALUE.
=cut
-=item Description
+=head2 Description
Returns the current value of Description.
(In the database, Description is stored as varchar(255).)
-=item SetDescription VALUE
+=head2 SetDescription VALUE
Set Description to VALUE.
=cut
-=item Type
+=head2 Type
Returns the current value of Type.
(In the database, Type is stored as varchar(16).)
-=item SetType VALUE
+=head2 SetType VALUE
Set Type to VALUE.
=cut
-=item Language
+=head2 Language
Returns the current value of Language.
(In the database, Language is stored as varchar(16).)
-=item SetLanguage VALUE
+=head2 SetLanguage VALUE
Set Language to VALUE.
=cut
-=item TranslationOf
+=head2 TranslationOf
Returns the current value of TranslationOf.
(In the database, TranslationOf is stored as int(11).)
-=item SetTranslationOf VALUE
+=head2 SetTranslationOf VALUE
Set TranslationOf to VALUE.
=cut
-=item Content
+=head2 Content
Returns the current value of Content.
(In the database, Content is stored as blob.)
-=item SetContent VALUE
+=head2 SetContent VALUE
Set Content to VALUE.
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Queue =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Name =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Description =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
Type =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
Language =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
TranslationOf =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Content =>
- {read => 1, write => 1, type => 'blob', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'blob', default => ''},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Template item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item EffectiveId
+=head2 EffectiveId
Returns the current value of EffectiveId.
(In the database, EffectiveId is stored as int(11).)
-=item SetEffectiveId VALUE
+=head2 SetEffectiveId VALUE
Set EffectiveId to VALUE.
=cut
-=item Queue
+=head2 Queue
Returns the current value of Queue.
(In the database, Queue is stored as int(11).)
-=item SetQueue VALUE
+=head2 SetQueue VALUE
Set Queue to VALUE.
=cut
-=item QueueObj
+=head2 QueueObj
Returns the Queue Object which has the id returned by Queue
return($Queue);
}
-=item Type
+=head2 Type
Returns the current value of Type.
(In the database, Type is stored as varchar(16).)
-=item SetType VALUE
+=head2 SetType VALUE
Set Type to VALUE.
=cut
-=item IssueStatement
+=head2 IssueStatement
Returns the current value of IssueStatement.
(In the database, IssueStatement is stored as int(11).)
-=item SetIssueStatement VALUE
+=head2 SetIssueStatement VALUE
Set IssueStatement to VALUE.
=cut
-=item Resolution
+=head2 Resolution
Returns the current value of Resolution.
(In the database, Resolution is stored as int(11).)
-=item SetResolution VALUE
+=head2 SetResolution VALUE
Set Resolution to VALUE.
=cut
-=item Owner
+=head2 Owner
Returns the current value of Owner.
(In the database, Owner is stored as int(11).)
-=item SetOwner VALUE
+=head2 SetOwner VALUE
Set Owner to VALUE.
=cut
-=item Subject
+=head2 Subject
Returns the current value of Subject.
(In the database, Subject is stored as varchar(200).)
-=item SetSubject VALUE
+=head2 SetSubject VALUE
Set Subject to VALUE.
=cut
-=item InitialPriority
+=head2 InitialPriority
Returns the current value of InitialPriority.
(In the database, InitialPriority is stored as int(11).)
-=item SetInitialPriority VALUE
+=head2 SetInitialPriority VALUE
Set InitialPriority to VALUE.
=cut
-=item FinalPriority
+=head2 FinalPriority
Returns the current value of FinalPriority.
(In the database, FinalPriority is stored as int(11).)
-=item SetFinalPriority VALUE
+=head2 SetFinalPriority VALUE
Set FinalPriority to VALUE.
=cut
-=item Priority
+=head2 Priority
Returns the current value of Priority.
(In the database, Priority is stored as int(11).)
-=item SetPriority VALUE
+=head2 SetPriority VALUE
Set Priority to VALUE.
=cut
-=item TimeEstimated
+=head2 TimeEstimated
Returns the current value of TimeEstimated.
(In the database, TimeEstimated is stored as int(11).)
-=item SetTimeEstimated VALUE
+=head2 SetTimeEstimated VALUE
Set TimeEstimated to VALUE.
=cut
-=item TimeWorked
+=head2 TimeWorked
Returns the current value of TimeWorked.
(In the database, TimeWorked is stored as int(11).)
-=item SetTimeWorked VALUE
+=head2 SetTimeWorked VALUE
Set TimeWorked to VALUE.
=cut
-=item Status
+=head2 Status
Returns the current value of Status.
(In the database, Status is stored as varchar(10).)
-=item SetStatus VALUE
+=head2 SetStatus VALUE
Set Status to VALUE.
=cut
-=item TimeLeft
+=head2 TimeLeft
Returns the current value of TimeLeft.
(In the database, TimeLeft is stored as int(11).)
-=item SetTimeLeft VALUE
+=head2 SetTimeLeft VALUE
Set TimeLeft to VALUE.
=cut
-=item Told
+=head2 Told
Returns the current value of Told.
(In the database, Told is stored as datetime.)
-=item SetTold VALUE
+=head2 SetTold VALUE
Set Told to VALUE.
=cut
-=item Starts
+=head2 Starts
Returns the current value of Starts.
(In the database, Starts is stored as datetime.)
-=item SetStarts VALUE
+=head2 SetStarts VALUE
Set Starts to VALUE.
=cut
-=item Started
+=head2 Started
Returns the current value of Started.
(In the database, Started is stored as datetime.)
-=item SetStarted VALUE
+=head2 SetStarted VALUE
Set Started to VALUE.
=cut
-=item Due
+=head2 Due
Returns the current value of Due.
(In the database, Due is stored as datetime.)
-=item SetDue VALUE
+=head2 SetDue VALUE
Set Due to VALUE.
=cut
-=item Resolved
+=head2 Resolved
Returns the current value of Resolved.
(In the database, Resolved is stored as datetime.)
-=item SetResolved VALUE
+=head2 SetResolved VALUE
Set Resolved to VALUE.
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
=cut
-=item Disabled
+=head2 Disabled
Returns the current value of Disabled.
(In the database, Disabled is stored as smallint(6).)
-=item SetDisabled VALUE
+=head2 SetDisabled VALUE
Set Disabled to VALUE.
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
EffectiveId =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Queue =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Type =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
IssueStatement =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Resolution =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Owner =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Subject =>
- {read => 1, write => 1, type => 'varchar(200)', default => '[no subject]'},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => '[no subject]'},
InitialPriority =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
FinalPriority =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Priority =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
TimeEstimated =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
TimeWorked =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Status =>
- {read => 1, write => 1, type => 'varchar(10)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 10, is_blob => 0, is_numeric => 0, type => 'varchar(10)', default => ''},
TimeLeft =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Told =>
- {read => 1, write => 1, type => 'datetime', default => ''},
+ {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Starts =>
- {read => 1, write => 1, type => 'datetime', default => ''},
+ {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Started =>
- {read => 1, write => 1, type => 'datetime', default => ''},
+ {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Due =>
- {read => 1, write => 1, type => 'datetime', default => ''},
+ {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Resolved =>
- {read => 1, write => 1, type => 'datetime', default => ''},
+ {read => 1, write => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
Disabled =>
- {read => 1, write => 1, type => 'smallint(6)', default => '0'},
+ {read => 1, write => 1, sql_type => 5, length => 6, is_blob => 0, is_numeric => 1, type => 'smallint(6)', default => '0'},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Ticket item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
#
+# CONTRIBUTION SUBMISSION POLICY:
#
-# END LICENSE BLOCK
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
package RT::Transaction;
use RT::Record;
-use RT::Ticket;
use vars qw( @ISA );
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
- int(11) 'EffectiveTicket'.
- int(11) 'Ticket'.
+ varchar(64) 'ObjectType'.
+ int(11) 'ObjectId'.
int(11) 'TimeTaken'.
varchar(20) 'Type'.
varchar(40) 'Field'.
varchar(255) 'OldValue'.
varchar(255) 'NewValue'.
- varchar(100) 'Data'.
+ varchar(255) 'ReferenceType'.
+ int(11) 'OldReference'.
+ int(11) 'NewReference'.
+ varchar(255) 'Data'.
=cut
sub Create {
my $self = shift;
my %args = (
- EffectiveTicket => '0',
- Ticket => '0',
+ ObjectType => '',
+ ObjectId => '0',
TimeTaken => '0',
Type => '',
Field => '',
OldValue => '',
NewValue => '',
+ ReferenceType => '',
+ OldReference => '',
+ NewReference => '',
Data => '',
@_);
$self->SUPER::Create(
- EffectiveTicket => $args{'EffectiveTicket'},
- Ticket => $args{'Ticket'},
+ ObjectType => $args{'ObjectType'},
+ ObjectId => $args{'ObjectId'},
TimeTaken => $args{'TimeTaken'},
Type => $args{'Type'},
Field => $args{'Field'},
OldValue => $args{'OldValue'},
NewValue => $args{'NewValue'},
+ ReferenceType => $args{'ReferenceType'},
+ OldReference => $args{'OldReference'},
+ NewReference => $args{'NewReference'},
Data => $args{'Data'},
);
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item EffectiveTicket
+=head2 ObjectType
-Returns the current value of EffectiveTicket.
-(In the database, EffectiveTicket is stored as int(11).)
+Returns the current value of ObjectType.
+(In the database, ObjectType is stored as varchar(64).)
-=item SetEffectiveTicket VALUE
+=head2 SetObjectType VALUE
-Set EffectiveTicket to VALUE.
+Set ObjectType to VALUE.
Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
-(In the database, EffectiveTicket will be stored as a int(11).)
+(In the database, ObjectType will be stored as a varchar(64).)
=cut
-=item Ticket
+=head2 ObjectId
-Returns the current value of Ticket.
-(In the database, Ticket is stored as int(11).)
+Returns the current value of ObjectId.
+(In the database, ObjectId is stored as int(11).)
-=item SetTicket VALUE
+=head2 SetObjectId VALUE
-Set Ticket to VALUE.
+Set ObjectId to VALUE.
Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
-(In the database, Ticket will be stored as a int(11).)
-
-
-=cut
-
-
-=item TicketObj
-
-Returns the Ticket Object which has the id returned by Ticket
+(In the database, ObjectId will be stored as a int(11).)
=cut
-sub TicketObj {
- my $self = shift;
- my $Ticket = RT::Ticket->new($self->CurrentUser);
- $Ticket->Load($self->__Value('Ticket'));
- return($Ticket);
-}
-=item TimeTaken
+=head2 TimeTaken
Returns the current value of TimeTaken.
(In the database, TimeTaken is stored as int(11).)
-=item SetTimeTaken VALUE
+=head2 SetTimeTaken VALUE
Set TimeTaken to VALUE.
=cut
-=item Type
+=head2 Type
Returns the current value of Type.
(In the database, Type is stored as varchar(20).)
-=item SetType VALUE
+=head2 SetType VALUE
Set Type to VALUE.
=cut
-=item Field
+=head2 Field
Returns the current value of Field.
(In the database, Field is stored as varchar(40).)
-=item SetField VALUE
+=head2 SetField VALUE
Set Field to VALUE.
=cut
-=item OldValue
+=head2 OldValue
Returns the current value of OldValue.
(In the database, OldValue is stored as varchar(255).)
-=item SetOldValue VALUE
+=head2 SetOldValue VALUE
Set OldValue to VALUE.
=cut
-=item NewValue
+=head2 NewValue
Returns the current value of NewValue.
(In the database, NewValue is stored as varchar(255).)
-=item SetNewValue VALUE
+=head2 SetNewValue VALUE
Set NewValue to VALUE.
=cut
-=item Data
+=head2 ReferenceType
+
+Returns the current value of ReferenceType.
+(In the database, ReferenceType is stored as varchar(255).)
+
+
+
+=head2 SetReferenceType VALUE
+
+
+Set ReferenceType to VALUE.
+Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
+(In the database, ReferenceType will be stored as a varchar(255).)
+
+
+=cut
+
+
+=head2 OldReference
+
+Returns the current value of OldReference.
+(In the database, OldReference is stored as int(11).)
+
+
+
+=head2 SetOldReference VALUE
+
+
+Set OldReference to VALUE.
+Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
+(In the database, OldReference will be stored as a int(11).)
+
+
+=cut
+
+
+=head2 NewReference
+
+Returns the current value of NewReference.
+(In the database, NewReference is stored as int(11).)
+
+
+
+=head2 SetNewReference VALUE
+
+
+Set NewReference to VALUE.
+Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
+(In the database, NewReference will be stored as a int(11).)
+
+
+=cut
+
+
+=head2 Data
Returns the current value of Data.
-(In the database, Data is stored as varchar(100).)
+(In the database, Data is stored as varchar(255).)
-=item SetData VALUE
+=head2 SetData VALUE
Set Data to VALUE.
Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
-(In the database, Data will be stored as a varchar(100).)
+(In the database, Data will be stored as a varchar(255).)
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
- EffectiveTicket =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
- Ticket =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
+ ObjectType =>
+ {read => 1, write => 1, sql_type => 12, length => 64, is_blob => 0, is_numeric => 0, type => 'varchar(64)', default => ''},
+ ObjectId =>
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
TimeTaken =>
- {read => 1, write => 1, type => 'int(11)', default => '0'},
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Type =>
- {read => 1, write => 1, type => 'varchar(20)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 20, is_blob => 0, is_numeric => 0, type => 'varchar(20)', default => ''},
Field =>
- {read => 1, write => 1, type => 'varchar(40)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 40, is_blob => 0, is_numeric => 0, type => 'varchar(40)', default => ''},
OldValue =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
NewValue =>
- {read => 1, write => 1, type => 'varchar(255)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
+ ReferenceType =>
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
+ OldReference =>
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
+ NewReference =>
+ {read => 1, write => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Data =>
- {read => 1, write => 1, type => 'varchar(100)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 255, is_blob => 0, is_numeric => 0, type => 'varchar(255)', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::Transaction item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
-=item Create PARAMHASH
+=head2 Create PARAMHASH
Create takes a hash of values and creates a row in the database:
-=item id
+=head2 id
Returns the current value of id.
(In the database, id is stored as int(11).)
=cut
-=item Name
+=head2 Name
Returns the current value of Name.
(In the database, Name is stored as varchar(200).)
-=item SetName VALUE
+=head2 SetName VALUE
Set Name to VALUE.
=cut
-=item Password
+=head2 Password
Returns the current value of Password.
(In the database, Password is stored as varchar(40).)
-=item SetPassword VALUE
+=head2 SetPassword VALUE
Set Password to VALUE.
=cut
-=item Comments
+=head2 Comments
Returns the current value of Comments.
(In the database, Comments is stored as blob.)
-=item SetComments VALUE
+=head2 SetComments VALUE
Set Comments to VALUE.
=cut
-=item Signature
+=head2 Signature
Returns the current value of Signature.
(In the database, Signature is stored as blob.)
-=item SetSignature VALUE
+=head2 SetSignature VALUE
Set Signature to VALUE.
=cut
-=item EmailAddress
+=head2 EmailAddress
Returns the current value of EmailAddress.
(In the database, EmailAddress is stored as varchar(120).)
-=item SetEmailAddress VALUE
+=head2 SetEmailAddress VALUE
Set EmailAddress to VALUE.
=cut
-=item FreeformContactInfo
+=head2 FreeformContactInfo
Returns the current value of FreeformContactInfo.
(In the database, FreeformContactInfo is stored as blob.)
-=item SetFreeformContactInfo VALUE
+=head2 SetFreeformContactInfo VALUE
Set FreeformContactInfo to VALUE.
=cut
-=item Organization
+=head2 Organization
Returns the current value of Organization.
(In the database, Organization is stored as varchar(200).)
-=item SetOrganization VALUE
+=head2 SetOrganization VALUE
Set Organization to VALUE.
=cut
-=item RealName
+=head2 RealName
Returns the current value of RealName.
(In the database, RealName is stored as varchar(120).)
-=item SetRealName VALUE
+=head2 SetRealName VALUE
Set RealName to VALUE.
=cut
-=item NickName
+=head2 NickName
Returns the current value of NickName.
(In the database, NickName is stored as varchar(16).)
-=item SetNickName VALUE
+=head2 SetNickName VALUE
Set NickName to VALUE.
=cut
-=item Lang
+=head2 Lang
Returns the current value of Lang.
(In the database, Lang is stored as varchar(16).)
-=item SetLang VALUE
+=head2 SetLang VALUE
Set Lang to VALUE.
=cut
-=item EmailEncoding
+=head2 EmailEncoding
Returns the current value of EmailEncoding.
(In the database, EmailEncoding is stored as varchar(16).)
-=item SetEmailEncoding VALUE
+=head2 SetEmailEncoding VALUE
Set EmailEncoding to VALUE.
=cut
-=item WebEncoding
+=head2 WebEncoding
Returns the current value of WebEncoding.
(In the database, WebEncoding is stored as varchar(16).)
-=item SetWebEncoding VALUE
+=head2 SetWebEncoding VALUE
Set WebEncoding to VALUE.
=cut
-=item ExternalContactInfoId
+=head2 ExternalContactInfoId
Returns the current value of ExternalContactInfoId.
(In the database, ExternalContactInfoId is stored as varchar(100).)
-=item SetExternalContactInfoId VALUE
+=head2 SetExternalContactInfoId VALUE
Set ExternalContactInfoId to VALUE.
=cut
-=item ContactInfoSystem
+=head2 ContactInfoSystem
Returns the current value of ContactInfoSystem.
(In the database, ContactInfoSystem is stored as varchar(30).)
-=item SetContactInfoSystem VALUE
+=head2 SetContactInfoSystem VALUE
Set ContactInfoSystem to VALUE.
=cut
-=item ExternalAuthId
+=head2 ExternalAuthId
Returns the current value of ExternalAuthId.
(In the database, ExternalAuthId is stored as varchar(100).)
-=item SetExternalAuthId VALUE
+=head2 SetExternalAuthId VALUE
Set ExternalAuthId to VALUE.
=cut
-=item AuthSystem
+=head2 AuthSystem
Returns the current value of AuthSystem.
(In the database, AuthSystem is stored as varchar(30).)
-=item SetAuthSystem VALUE
+=head2 SetAuthSystem VALUE
Set AuthSystem to VALUE.
=cut
-=item Gecos
+=head2 Gecos
Returns the current value of Gecos.
(In the database, Gecos is stored as varchar(16).)
-=item SetGecos VALUE
+=head2 SetGecos VALUE
Set Gecos to VALUE.
=cut
-=item HomePhone
+=head2 HomePhone
Returns the current value of HomePhone.
(In the database, HomePhone is stored as varchar(30).)
-=item SetHomePhone VALUE
+=head2 SetHomePhone VALUE
Set HomePhone to VALUE.
=cut
-=item WorkPhone
+=head2 WorkPhone
Returns the current value of WorkPhone.
(In the database, WorkPhone is stored as varchar(30).)
-=item SetWorkPhone VALUE
+=head2 SetWorkPhone VALUE
Set WorkPhone to VALUE.
=cut
-=item MobilePhone
+=head2 MobilePhone
Returns the current value of MobilePhone.
(In the database, MobilePhone is stored as varchar(30).)
-=item SetMobilePhone VALUE
+=head2 SetMobilePhone VALUE
Set MobilePhone to VALUE.
=cut
-=item PagerPhone
+=head2 PagerPhone
Returns the current value of PagerPhone.
(In the database, PagerPhone is stored as varchar(30).)
-=item SetPagerPhone VALUE
+=head2 SetPagerPhone VALUE
Set PagerPhone to VALUE.
=cut
-=item Address1
+=head2 Address1
Returns the current value of Address1.
(In the database, Address1 is stored as varchar(200).)
-=item SetAddress1 VALUE
+=head2 SetAddress1 VALUE
Set Address1 to VALUE.
=cut
-=item Address2
+=head2 Address2
Returns the current value of Address2.
(In the database, Address2 is stored as varchar(200).)
-=item SetAddress2 VALUE
+=head2 SetAddress2 VALUE
Set Address2 to VALUE.
=cut
-=item City
+=head2 City
Returns the current value of City.
(In the database, City is stored as varchar(100).)
-=item SetCity VALUE
+=head2 SetCity VALUE
Set City to VALUE.
=cut
-=item State
+=head2 State
Returns the current value of State.
(In the database, State is stored as varchar(100).)
-=item SetState VALUE
+=head2 SetState VALUE
Set State to VALUE.
=cut
-=item Zip
+=head2 Zip
Returns the current value of Zip.
(In the database, Zip is stored as varchar(16).)
-=item SetZip VALUE
+=head2 SetZip VALUE
Set Zip to VALUE.
=cut
-=item Country
+=head2 Country
Returns the current value of Country.
(In the database, Country is stored as varchar(50).)
-=item SetCountry VALUE
+=head2 SetCountry VALUE
Set Country to VALUE.
=cut
-=item Timezone
+=head2 Timezone
Returns the current value of Timezone.
(In the database, Timezone is stored as varchar(50).)
-=item SetTimezone VALUE
+=head2 SetTimezone VALUE
Set Timezone to VALUE.
=cut
-=item PGPKey
+=head2 PGPKey
Returns the current value of PGPKey.
(In the database, PGPKey is stored as text.)
-=item SetPGPKey VALUE
+=head2 SetPGPKey VALUE
Set PGPKey to VALUE.
=cut
-=item Creator
+=head2 Creator
Returns the current value of Creator.
(In the database, Creator is stored as int(11).)
=cut
-=item Created
+=head2 Created
Returns the current value of Created.
(In the database, Created is stored as datetime.)
=cut
-=item LastUpdatedBy
+=head2 LastUpdatedBy
Returns the current value of LastUpdatedBy.
(In the database, LastUpdatedBy is stored as int(11).)
=cut
-=item LastUpdated
+=head2 LastUpdated
Returns the current value of LastUpdated.
(In the database, LastUpdated is stored as datetime.)
-sub _ClassAccessible {
+sub _CoreAccessible {
{
id =>
- {read => 1, type => 'int(11)', default => ''},
+ {read => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => ''},
Name =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Password =>
- {read => 1, write => 1, type => 'varchar(40)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 40, is_blob => 0, is_numeric => 0, type => 'varchar(40)', default => ''},
Comments =>
- {read => 1, write => 1, type => 'blob', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'blob', default => ''},
Signature =>
- {read => 1, write => 1, type => 'blob', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'blob', default => ''},
EmailAddress =>
- {read => 1, write => 1, type => 'varchar(120)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 120, is_blob => 0, is_numeric => 0, type => 'varchar(120)', default => ''},
FreeformContactInfo =>
- {read => 1, write => 1, type => 'blob', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'blob', default => ''},
Organization =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
RealName =>
- {read => 1, write => 1, type => 'varchar(120)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 120, is_blob => 0, is_numeric => 0, type => 'varchar(120)', default => ''},
NickName =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
Lang =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
EmailEncoding =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
WebEncoding =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
ExternalContactInfoId =>
- {read => 1, write => 1, type => 'varchar(100)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 100, is_blob => 0, is_numeric => 0, type => 'varchar(100)', default => ''},
ContactInfoSystem =>
- {read => 1, write => 1, type => 'varchar(30)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 30, is_blob => 0, is_numeric => 0, type => 'varchar(30)', default => ''},
ExternalAuthId =>
- {read => 1, write => 1, type => 'varchar(100)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 100, is_blob => 0, is_numeric => 0, type => 'varchar(100)', default => ''},
AuthSystem =>
- {read => 1, write => 1, type => 'varchar(30)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 30, is_blob => 0, is_numeric => 0, type => 'varchar(30)', default => ''},
Gecos =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
HomePhone =>
- {read => 1, write => 1, type => 'varchar(30)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 30, is_blob => 0, is_numeric => 0, type => 'varchar(30)', default => ''},
WorkPhone =>
- {read => 1, write => 1, type => 'varchar(30)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 30, is_blob => 0, is_numeric => 0, type => 'varchar(30)', default => ''},
MobilePhone =>
- {read => 1, write => 1, type => 'varchar(30)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 30, is_blob => 0, is_numeric => 0, type => 'varchar(30)', default => ''},
PagerPhone =>
- {read => 1, write => 1, type => 'varchar(30)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 30, is_blob => 0, is_numeric => 0, type => 'varchar(30)', default => ''},
Address1 =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
Address2 =>
- {read => 1, write => 1, type => 'varchar(200)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 200, is_blob => 0, is_numeric => 0, type => 'varchar(200)', default => ''},
City =>
- {read => 1, write => 1, type => 'varchar(100)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 100, is_blob => 0, is_numeric => 0, type => 'varchar(100)', default => ''},
State =>
- {read => 1, write => 1, type => 'varchar(100)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 100, is_blob => 0, is_numeric => 0, type => 'varchar(100)', default => ''},
Zip =>
- {read => 1, write => 1, type => 'varchar(16)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 16, is_blob => 0, is_numeric => 0, type => 'varchar(16)', default => ''},
Country =>
- {read => 1, write => 1, type => 'varchar(50)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 50, is_blob => 0, is_numeric => 0, type => 'varchar(50)', default => ''},
Timezone =>
- {read => 1, write => 1, type => 'varchar(50)', default => ''},
+ {read => 1, write => 1, sql_type => 12, length => 50, is_blob => 0, is_numeric => 0, type => 'varchar(50)', default => ''},
PGPKey =>
- {read => 1, write => 1, type => 'text', default => ''},
+ {read => 1, write => 1, sql_type => -4, length => 0, is_blob => 1, is_numeric => 0, type => 'text', default => ''},
Creator =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
Created =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
LastUpdatedBy =>
- {read => 1, auto => 1, type => 'int(11)', default => '0'},
+ {read => 1, auto => 1, sql_type => 4, length => 11, is_blob => 0, is_numeric => 1, type => 'int(11)', default => '0'},
LastUpdated =>
- {read => 1, auto => 1, type => 'datetime', default => ''},
+ {read => 1, auto => 1, sql_type => 11, length => 0, is_blob => 0, is_numeric => 0, type => 'datetime', default => ''},
}
};
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
-# BEGIN LICENSE BLOCK
+# BEGIN BPS TAGGED BLOCK {{{
#
-# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2005 Best Practical Solutions, LLC
+# <jesse@bestpractical.com>
#
-# (Except where explictly superceded by other copyright notices)
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
#
# This work is made available to you under the terms of Version 2 of
# the GNU General Public License. A copy of that license should have
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
-# Unless otherwise specified, all modifications, corrections or
-# extensions to this work which alter its source code become the
-# property of Best Practical Solutions, LLC when submitted for
-# inclusion in the work.
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
#
-# END LICENSE BLOCK
+# END BPS TAGGED BLOCK }}}
# Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
#
}
-=item NewItem
+=head2 NewItem
Returns an empty new RT::User item
These overlay files can contain new subs or subs to replace existing subs in this module.
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+Each of these files should begin with the line
no warnings qw(redefine);
projects / freeside.git / commitdiff