From: cvs2git Date: Tue, 26 Oct 2004 13:08:19 +0000 (+0000) Subject: This commit was manufactured by cvs2svn to create tag 'freeside_1_4_2beta1'. X-Git-Tag: freeside_1_4_2beta1 X-Git-Url: http://git.freeside.biz/gitweb/?a=commitdiff_plain;h=refs%2Ftags%2Ffreeside_1_4_2beta1;p=freeside.git This commit was manufactured by cvs2svn to create tag 'freeside_1_4_2beta1'. --- d73b26abb947fec52fc2807c52b8ad322a30d9a0 diff --cc fs_signup/fs_signup_server index d6eb4a8d5,d6eb4a8d5..000000000 deleted file mode 100755,100755 --- a/fs_signup/fs_signup_server +++ /dev/null @@@ -1,289 -1,289 +1,0 @@@ --#!/usr/bin/perl -Tw --# --# fs_signup_server --# -- --use strict; --use vars qw($pid); --use IO::Handle; --use Storable qw(nstore_fd fd_retrieve); --use Tie::RefHash; --use Net::SSH qw(sshopen2); --use FS::UID qw(adminsuidsetup); --use FS::Conf; --use FS::Record qw( qsearch qsearchs ); --use FS::cust_main_county; --use FS::cust_main; --use FS::cust_bill; --use FS::cust_pkg; --use FS::Msgcat qw(gettext); -- --use vars qw( $opt $Debug ); -- --$Debug = 2; -- --my $user = shift or die &usage; --&adminsuidsetup( $user ); -- --my $conf = new FS::Conf; -- --if ($conf->exists('signup_server-quiet')) { -- $FS::cust_bill::quiet = 1; -- $FS::cust_pkg::quiet = 1; --} -- --#my @payby = qw(CARD PREPAY); --my @payby = $conf->config('signup_server-payby'); --my $smtpmachine = $conf->config('smtpmachine'); -- --my $machine = shift or die &usage; -- --my $agentnum = shift or die &usage; --my $agent = qsearchs( 'agent', { 'agentnum' => $agentnum } ) or die &usage; --my $pkgpart_href = $agent->pkgpart_hashref; -- --my $refnum = shift or die &usage; -- --#causing trouble for some folks --#$SIG{CHLD} = sub { wait() }; -- --$SIG{HUP} = \&killssh; --$SIG{INT} = \&killssh; --$SIG{QUIT} = \&killssh; --$SIG{TERM} = \&killssh; --$SIG{PIPE} = \&killssh; --sub killssh { kill 'TERM', $pid if $pid; exit; }; -- --my($fs_signupd)="/usr/local/sbin/fs_signupd"; -- --while (1) { -- my($reader,$writer)=(new IO::Handle, new IO::Handle); -- #seems to be broken - calling ->flush explicitly# $writer->autoflush(1); -- warn "[fs_signup_server] Connecting to $machine...\n" if $Debug; -- $pid = sshopen2($machine,$reader,$writer,$fs_signupd); -- -- my @pops = qsearch('svc_acct_pop',{} ); -- my $init_data = { -- -- #'_protocol' => 'signup', -- #'_version' => '0.1', -- #'_packet' => 'init' -- -- 'cust_main_county' => -- [ map { $_->hashref } qsearch('cust_main_county', {}) ], -- -- 'part_pkg' => -- [ -- #map { $_->hashref } -- map { { 'payby' => [ $_->payby ], %{$_->hashref} } } -- grep { $_->svcpart('svc_acct') && $pkgpart_href->{ $_->pkgpart } } -- qsearch( 'part_pkg', { 'disabled' => '' } ) -- ], -- -- 'agentnum2part_pkg' => -- { -- map { -- my $href = $_->pkgpart_hashref; -- $_->agentnum => -- [ -- map { { 'payby' => [ $_->payby ], %{$_->hashref} } } -- grep { $_->svcpart('svc_acct') && $href->{ $_->pkgpart } } -- qsearch( 'part_pkg', { 'disabled' => '' } ) -- ]; -- } qsearch('agent', {} ) -- }, -- -- 'svc_acct_pop' => [ map { $_->hashref } @pops ], -- -- 'security_phrase' => $conf->exists('security_phrase'), -- -- 'payby' => [ $conf->config('signup_server-payby') ], -- -- 'msgcat' => { map { $_=>gettext($_) } qw( -- passwords_dont_match invalid_card unknown_card_type not_a -- ) }, -- -- 'statedefault' => $conf->config('statedefault') || 'CA', -- -- 'countrydefault' => $conf->config('countrydefault') || 'US', -- -- }; -- -- warn "[fs_signup_server] Sending init data...\n" if $Debug; -- nstore_fd($init_data, $writer) or die "can't send init data: $!"; -- $writer->flush; -- -- warn "[fs_signup_server] Entering main loop...\n" if $Debug; -- while (1) { -- warn "[fs_signup_server] Reading (waiting for) signup data...\n" if $Debug; -- my $signup_data = fd_retrieve($reader); -- -- if ( $Debug > 1 ) { -- warn join('', -- map { " $_ => ". $signup_data->{$_}. "\n" } keys %$signup_data ); -- } -- -- warn "[fs_signup_server] Processing signup...\n" if $Debug; -- -- my $error = ''; -- -- #things that aren't necessary in base class, but are for signup server -- #return "Passwords don't match" -- # if $hashref->{'_password'} ne $hashref->{'_password2'} -- $error ||= gettext('empty_password') unless $signup_data->{'_password'}; -- $error ||= gettext('no_access_number_selected') -- unless $signup_data->{'popnum'} || !scalar(@pops); -- -- #shares some stuff with htdocs/edit/process/cust_main.cgi... take any -- # common that are still here and library them. -- my $cust_main = new FS::cust_main ( { -- #'custnum' => '', -- 'agentnum' => $signup_data->{agentnum} || $agentnum, -- 'refnum' => $refnum, -- -- map { $_ => $signup_data->{$_} } qw( -- last first ss company address1 address2 city county state zip country -- daytime night fax payby payinfo paydate payname referral_custnum comments -- ), -- -- } ); -- -- $error ||= "Illegal payment type" -- unless grep { $_ eq $signup_data->{'payby'} } @payby; -- -- $cust_main->payinfo($cust_main->daytime) -- if $cust_main->payby eq 'LECB' && ! $cust_main->payinfo; -- -- my @invoicing_list = split( /\s*\,\s*/, $signup_data->{'invoicing_list'} ); -- -- $signup_data->{'pkgpart'} =~ /^(\d+)$/ or '' =~ /^()$/; -- my $pkgpart = $1; -- -- my $part_pkg = -- qsearchs( 'part_pkg', { 'pkgpart' => $pkgpart } ) -- or $error ||= "WARNING: unknown pkgpart: $pkgpart"; -- my $svcpart = $part_pkg->svcpart('svc_acct') unless $error; -- -- my $cust_pkg = new FS::cust_pkg ( { -- #later#'custnum' => $custnum, -- 'pkgpart' => $signup_data->{'pkgpart'}, -- } ); -- $error ||= $cust_pkg->check; -- -- my $svc_acct = new FS::svc_acct ( { -- 'svcpart' => $svcpart, -- map { $_ => $signup_data->{$_} } -- qw( username _password sec_phrase popnum ), -- } ); -- -- my $y = $svc_acct->setdefault; # arguably should be in new method -- $error ||= $y unless ref($y); -- -- $error ||= $svc_acct->check; -- -- use Tie::RefHash; -- tie my %hash, 'Tie::RefHash'; -- %hash = ( $cust_pkg => [ $svc_acct ] ); -- $error ||= $cust_main->insert( \%hash, \@invoicing_list ); #msgcat -- -- if ( ! $error && $conf->exists('signup_server-realtime') ) { -- -- warn "[fs_signup_server] Billing customer...\n" if $Debug; -- -- my $bill_error = $cust_main->bill; -- warn "[fs_signup_server] error billing new customer: $bill_error" -- if $bill_error; -- -- $cust_main->apply_payments; -- $cust_main->apply_credits; -- -- $bill_error = $cust_main->collect; -- warn "[fs_signup_server] error collecting from new customer: $bill_error" -- if $bill_error; -- -- if ( $cust_main->balance > 0 ) { -- -- #this makes sense. credit is "un-doing" the invoice -- $cust_main->credit( $cust_main->balance, 'signup server decline' ); -- $cust_main->apply_credits; -- -- #should check list for errors... -- #$cust_main->suspend; -- $cust_main->cancel; -- -- $error = '_decline'; -- } -- } -- -- warn "[fs_signup_server] Sending results...\n" if $Debug; -- print $writer $error, "\n"; -- -- next if $error; -- -- if ( $conf->config('signup_server-email') ) { -- warn "[fs_signup_server] Sending email...\n" if $Debug; -- -- #false laziness w/FS::cust_bill::send & FS::cust_pay::delete -- use Mail::Header; -- use Mail::Internet 1.44; -- use Date::Format; -- my $from = $conf->config('invoice_from'); #??? as good as any -- $ENV{MAILADDRESS} = $from; -- my $header = new Mail::Header ( [ -- "From: $from", -- "To: ". $conf->config('signup_server-email'), -- "Sender: $from", -- "Reply-To: $from", -- "Date: ". time2str("%a, %d %b %Y %X %z", time), -- "Subject: FREESIDE NOTIFICATION: Signup Server", -- ] ); -- my $body = [ -- "This is an automatic message from your Freeside installation\n", -- "informing you a customer has signed up via the signup server:\n", -- "\n", -- 'custnum : '. $cust_main->custnum. "\n", -- 'Name : '. $cust_main->last. ", ". $cust_main->first. "\n", -- 'Agent : '. $cust_main->agent->agent. "\n", -- 'Package : '. $part_pkg->pkg. ' - '. $part_pkg->comment. "\n", -- 'Signup Date : '. time2str('%C', time). "\n", -- 'Username : '. $svc_acct->username. "\n", -- #'Password : '. # config file to turn this on if noment insists -- 'Day phone : '. $cust_main->daytime. "\n", -- 'Night phone : '. $cust_main->night. "\n", -- 'Address : '. $cust_main->address1. "\n", -- ( $cust_main->address2 -- ? ' '. $cust_main->address2. "\n" -- : '' ), -- ' '. $cust_main->city. ', '. $cust_main->state. ' '. -- $cust_main->zip. "\n", -- ( $cust_main->country eq 'US' -- ? '' -- : ' '. $cust_main->country. "\n" ), -- "\n", -- ]; -- #if ( $cust_main->balance > 0 ) { -- # push @$body, -- # "This customer has an outstanding balance and has been suspended.\n"; -- #} -- my $message = new Mail::Internet ( 'Header' => $header, 'Body' => $body ); -- $!=0; -- $message->smtpsend( Host => $smtpmachine ) -- or $message->smtpsend( Host => $smtpmachine, Debug => 1 ) -- or warn "[fs_signup_server] can't send email to ". -- $conf->config('signup_server-email'). -- " via server $smtpmachine with SMTP: $!"; -- #end-of-send mail -- } -- -- } -- close $writer; -- close $reader; -- warn "connection to $machine lost! waiting 60 seconds...\n"; -- sleep 60; -- warn "reconnecting...\n"; --} -- --sub usage { -- die "Usage:\n\n fs_signup_server user machine agentnum refnum\n"; --} -- diff --cc httemplate/docs/man/FS/part_export/.cvs_is_on_crack index e69de29bb,e69de29bb..000000000 deleted file mode 100644,100644 --- a/httemplate/docs/man/FS/part_export/.cvs_is_on_crack +++ /dev/null diff --cc install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm index 1a92baae1,1a92baae1..000000000 deleted file mode 100644,100644 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Index.pm +++ /dev/null @@@ -1,37 -1,37 +1,0 @@@ --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::ColGroup::Index --inherits from DBIx::DBSchema::ColGroup. -- --=head1 BUGS -- --Is this empty subclass needed? -- --=head1 SEE ALSO -- --L, L, --L, L, L -- --=cut -- --1; -- diff --cc install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm index 450043fdf,450043fdf..000000000 deleted file mode 100644,100644 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/ColGroup/Unique.pm +++ /dev/null @@@ -1,38 -1,38 +1,0 @@@ --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::ColGroup:Unique --inherits from DBIx::DBSchema::ColGroup. -- --=head1 BUGS -- --Is this empty subclass needed? -- --=head1 SEE ALSO -- --L, L, --L, L, L -- --=cut -- --1; -- -- diff --cc install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm index 018b89028,018b89028..000000000 deleted file mode 100644,100644 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Pg.pm +++ /dev/null @@@ -1,175 -1,175 +1,0 @@@ --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(<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(<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(<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(<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(<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(<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 -- --=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, L, L, L -- --=cut -- --1; -- diff --cc install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm index 4a740693a,4a740693a..000000000 deleted file mode 100755,100755 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/Sybase.pm +++ /dev/null @@@ -1,141 -1,141 +1,0 @@@ --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(<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 --(courtesy of Ivan Kohler ) -- --Mitchell Friedman -- --Bernd Dulfer -- --=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 method does not yet work. -- --=head1 SEE ALSO -- --L, L, L, L -- --=cut -- --1; -- diff --cc install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm index f3804dd28,f3804dd28..000000000 deleted file mode 100644,100644 --- a/install/5.005/DBIx-DBSchema-0.23-5.005kludge/DBSchema/DBD/mysql.pm +++ /dev/null @@@ -1,126 -1,126 +1,0 @@@ --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 -- --=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, L, L, L -- --=cut -- --1; --