grep { $_->suspend } $self->unsuspended_pkgs;
}
-=item suspend_if_pkgpart PKGPART [ , PKGPART ... ]
-
-Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
-PKGPARTs (see L<FS::part_pkg>). Always returns a list: an empty list on
-success or a list of errors.
-
-=cut
-
-sub suspend_if_pkgpart {
- my $self = shift;
- my @pkgparts = @_;
- grep { $_->suspend }
- grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
- $self->unsuspended_pkgs;
-}
-
-=item suspend_unless_pkgpart PKGPART [ , PKGPART ... ]
-
-Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
-listed PKGPARTs (see L<FS::part_pkg>). Always returns a list: an empty list
-on success or a list of errors.
-
-=cut
-
-sub suspend_unless_pkgpart {
- my $self = shift;
- my @pkgparts = @_;
- grep { $_->suspend }
- grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
- $self->unsuspended_pkgs;
-}
-
=item cancel [ OPTION => VALUE ... ]
Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
|| $self->ut_textn('plan')
|| $self->ut_anything('plandata')
;
- #|| $self->ut_snumber('seconds')
return $error if $error;
#quelle kludge
- if ( $self->plandata =~ /^(agent_)?templatename\s+(.*)$/m ) {
- my $name= $2;
-
- foreach my $file (qw( template latex latexnotes )) {
- unless ( $conf->exists("invoice_${file}_$name") ) {
- $conf->set(
- "invoice_${file}_$name" =>
- join("\n", $conf->config("invoice_$file") )
- );
- }
+ if ( $self->plandata =~ /^templatename\s+(.*)$/ ) {
+ my $name= $1;
+ unless ( $conf->exists("invoice_template_$name") ) {
+ $conf->set(
+ "invoice_template_$name" =>
+ join("\n", $conf->config('invoice_template') )
+ );
+ }
+ unless ( $conf->exists("invoice_latex_$name") ) {
+ $conf->set(
+ "invoice_latex_$name" =>
+ join("\n", $conf->config('invoice_latex') )
+ );
}
}
+++ /dev/null
-#!/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";
-}
-
#print ntable();
-sub select_pkgpart {
- my $label = shift;
- my $plandata = shift;
- my %selected = map { $_=>1 } split(/,\s*/, $plandata->{$label});
- qq(<SELECT NAME="$label" MULTIPLE>).
- join("\n", map {
- '<OPTION VALUE="'. $_->pkgpart. '"'.
- ( $selected{$_->pkgpart} ? ' SELECTED' : '' ).
- '>'. $_->pkg. ' - '. $_->comment
- } qsearch('part_pkg', { 'disabled' => '' } ) ).
- '</SELECT>';
-}
-
-sub select_agentnum {
- my $plandata = shift;
- my $agentnum = $plandata->{'agentnum'};
- '<SELECT NAME="agentnum">'.
- join("\n", map {
- '<OPTION VALUE="'. $_->agentnum. '"'.
- ( $_->agentnum == $agentnum ? ' SELECTED' : '' ).
- '>'. $_->agent
- } qsearch('agent', { 'disabled' => '' } ) ).
- '</SELECT>';
-}
-
#this is pretty kludgy right here.
tie my %events, 'Tie::IxHash',
'code' => '$cust_main->suspend();',
'weight' => 10,
},
- 'suspend-if-pkgpart' => {
- 'name' => 'Suspend packages',
- 'code' => '$cust_main->suspend_if_pkgpart(%%%if_pkgpart%%%);',
- 'html' => sub { &select_pkgpart('if_pkgpart', @_) },
- 'weight' => 10,
- },
- 'suspend-unless-pkgpart' => {
- 'name' => 'Suspend packages except',
- 'code' => '$cust_main->suspend_unless_pkgpart(%%%unless_pkgpart%%%);',
- 'html' => sub { &select_pkgpart('unless_pkgpart', @_) },
- 'weight' => 10,
- },
'cancel' => {
'name' => 'Cancel',
'code' => '$cust_main->cancel();',
'weight' => 50,
},
- 'send_agent' => {
- 'name' => 'Send invoice (email/print) ',
- 'code' => '$cust_bill->send(\'%%%agent_templatename%%%\', %%%agentnum%%%);',
- 'html' => sub {
- '<TABLE BORDER=0>
- <TR>
- <TD ALIGN="right">only for agent </TD>
- <TD>'. &select_agentnum(@_). '</TD>
- </TR>
- <TR>
- <TD ALIGN="right">with template </TD>
- <TD>
- <INPUT TYPE="text" NAME="agent_templatename" VALUE="%%%agent_templatename%%%">
- </TD>
- </TR>
- </TABLE>';
- },
- 'weight' => 50,
- },
-
'send_csv_ftp' => {
'name' => 'Upload CSV invoice data to an FTP server',
'code' => '$cust_bill->send_csv( protocol => \'ftp\',
my %plandata = map { /^(\w+) (.*)$/; ($1, $2); }
split(/\n/, $part_bill_event->plandata);
my $html = $events{$event}{html};
- if ( ref($html) eq 'CODE' ) {
- $html = &{$html}(\%plandata);
- }
while ( $html =~ /%%%(\w+)%%%/ ) {
my $field = $1;
$html =~ s/%%%$field%%%/$plandata{$field}/;
my $old = qsearchs('part_bill_event',{'eventpart'=>$eventpart}) if $eventpart;
#s/days/seconds/
-$cgi->param('seconds', int( $cgi->param('days') * 86400 ) );
+$cgi->param('seconds', $cgi->param('days') * 86400 );
my $error;
if ( ! $cgi->param('plan_weight_eventcode') ) {
my $plandata = '';
while ( $eventcode =~ /%%%(\w+)%%%/ ) {
my $field = $1;
- my $value = join(', ', $cgi->param($field) );
- $cgi->param($field, $value); #in case it errors out
+ my $value = $cgi->param($field);
$eventcode =~ s/%%%$field%%%/$value/;
$plandata .= "$field $value\n";
}
+++ /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::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;
-
projects / freeside.git / commitdiff