[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SF.net SVN: ledger-smb:[4501] trunk/LedgerSMB/DBObject_Moose.pm
- Subject: SF.net SVN: ledger-smb:[4501] trunk/LedgerSMB/DBObject_Moose.pm
- From: ..hidden..
- Date: Sat, 17 Mar 2012 03:50:51 +0000
Revision: 4501
http://ledger-smb.svn.sourceforge.net/ledger-smb/?rev=4501&view=rev
Author: einhverfr
Date: 2012-03-17 03:50:51 +0000 (Sat, 17 Mar 2012)
Log Message:
-----------
Consolidated code so as to support old DBObject API and new DBObject_Moose api. The latter is better for more mature code, and the other better at present for less mature code.
Modified Paths:
--------------
trunk/LedgerSMB/DBObject_Moose.pm
Modified: trunk/LedgerSMB/DBObject_Moose.pm
===================================================================
--- trunk/LedgerSMB/DBObject_Moose.pm 2012-03-17 03:14:43 UTC (rev 4500)
+++ trunk/LedgerSMB/DBObject_Moose.pm 2012-03-17 03:50:51 UTC (rev 4501)
@@ -35,9 +35,6 @@
the operation will not raise an exception in the event of a database error, and
it will be up to the application to handle any exceptions.
-=item __validate__ is called on every new() invocation. It is blank in this
-module but can be overridden in decendant modules.
-
=item _db_array_scalars(@elements) creates a db array from scalars.
=item _db_array_literal(@elements) creates a multiple dimension db array from
@@ -46,10 +43,16 @@
=cut
package LedgerSMB::DBObject_Moose;
+use LedgerSMB::DBObject;
use Moose;
use Scalar::Util;
use Log::Log4perl;
+use LedgerSMB::DBObject;
+my $logger = Log::Log4perl->get_logger('LedgerSMB::DBObject');
+
+sub __validate__ {}
+
has 'dbh' => (is => 'ro', isa => 'DBI::db', required => '1');
has '_roles' => (is => 'ro', isa => 'ArrayRef[Str]', required => '1');
has '_user' => (is => 'ro', isa => 'LedgerSMB::User', required => '1');
@@ -66,112 +69,26 @@
}
}
+# _to_dbobject
+#Private method used to convert to db object for purposes of
+#
+sub _to_dbobject {
+ my $self = shift @_;
+ return LedgerSMB::DBObject->new({base => $self});
+}
-my $logger = Log::Log4perl->get_logger('LedgerSMB::DBObject');
-
-sub __validate__ {}
-
=item set_ordering
Sets the ordering used by default for specific functions called by exec_method
=cut
-sub set_ordering {
- my ($self, $args) = @_;
- $self->{_order_method}->{$args->{method}} =
- $self->{dbh}->quote_identifier($args->{column});
-}
-
sub exec_method {
my $self = shift @_;
- my %args = (ref($_[0]) eq 'HASH')? %{$_[0]}: @_;
- my $funcname = $args{funcname};
-
- my $schema = $args{schema} || $LedgerSMB::Sysconfig::db_namespace;
-
- $logger->debug("exec_method: \$funcname = $funcname");
- my @in_args;
- @in_args = @{ $args{args} } if $args{args};
-
- my @call_args;
-
- my $query = "
- SELECT proname, pronargs, proargnames FROM pg_proc
- WHERE proname = ?
- AND pronamespace =
- coalesce((SELECT oid FROM pg_namespace WHERE nspname = ?),
- pronamespace)
- ";
- my $sth = $self->{dbh}->prepare(
- $query
- );
- $sth->execute($funcname, $schema)
- || $self->error($DBI::errstr . "in exec_method");
- my $ref;
-
- $ref = $sth->fetchrow_hashref('NAME_lc');
-
- my $pargs = $ref->{proargnames};
- my @proc_args;
-
- if ( !$ref->{proname} ) { # no such function
- # If the function doesn't exist, $funcname gets zeroed?
- $self->error( "No such function: $funcname");
-# die;
- }
- $ref->{pronargs} = 0 unless defined $ref->{pronargs};
- # If the user provided args..
- if (!defined $args{args}) {
- @proc_args = $self->_parse_array($pargs);
- if (@proc_args) {
- for my $arg (@proc_args) {
- #print STDERR "User Provided Args: $arg\n";
- if ( $arg =~ s/^in_// ) {
- if ( defined $self->{$arg} )
- {
- $logger->debug("exec_method pushing $arg = $self->{$arg}");
- }
- else
- {
- $logger->debug("exec_method pushing \$arg defined $arg | \$self->{\$arg} is undefined");
- #$self->{$arg} = undef; # Why was this being unset? --CT
- }
- push ( @call_args, $self->{$arg} );
- }
- }
- }
- for (@in_args) { push @call_args, $_ } ;
- $self->{call_args} = ..hidden..;
- $logger->debug("exec_method: \$self = " . Data::Dumper::Dumper($self));
- for my $arg(@call_args){
- if (defined $arg && eval {$arg->can('to_db')}){
- $arg = $arg->to_db;
- }
- }
-
- return $self->call_procedure( procname => $funcname,
- args => ..hidden..,
- order_by => $self->{_order_method}->{"$funcname"},
- schema=>$schema,
- continue_on_error => $args{continue_on_error});
- }
- else {
- for my $arg(@in_args){
- if (eval {$arg->can('to_db')}){
- $arg = $arg->to_db;
- }
- }
-
- return $self->call_procedure( procname => $funcname,
- args => ..hidden..,
- order_by => $self->{_order_method}->{"$funcname"},
- schema=>$schema,
- continue_on_error => $args{continue_on_error});
- }
+ my $dbo = $self->_to_dbobject;
+ return $dbo->exec_method(@_);
}
-
=item run_custom_queries
Backward-compatible with 1.2 custom query system for moving forward.
@@ -179,281 +96,24 @@
=cut
sub run_custom_queries {
- my ( $self, $tablename, $query_type, $linenum ) = @_;
- my $dbh = $self->{dbh};
- if ( $query_type !~ /^(select|insert|update)$/i ) {
-
- # Commenting out this next bit until we figure out how the locale object
- # will operate. Chris
- #$self->error($locale->text(
- # "Passed incorrect query type to run_custom_queries."
- #));
- }
- my @rc;
- my %temphash;
- my @templist;
- my $did_insert;
- my @elements;
- my $query;
- my $ins_values;
-
- if ($linenum) {
- $linenum = "_$linenum";
- }
-
- $query_type = uc($query_type);
- for ( @{ $self->{custom_db_fields}{$tablename} } ) {
- @elements = split( /:/, $_ );
- push @{ $temphash{ $elements[0] } }, $elements[1];
- }
- for ( keys %temphash ) {
- my @data;
- $query = "$query_type ";
- if ( $query_type eq 'UPDATE' ) {
- $query = "DELETE FROM $_ WHERE row_id = ?";
- my $sth = $dbh->prepare($query);
- $sth->execute( $self->{ "id" . "$linenum" } )
- || $self->dberror($query);
- }
- elsif ( $query_type eq 'INSERT' ) {
- $query .= " INTO $_ (";
- }
- my $first = 1;
- for ( @{ $temphash{$_} } ) {
- $query .= "$_";
- if ( $query_type eq 'UPDATE' ) {
- $query .= '= ?';
- }
- $ins_values .= "?, ";
- $query .= ", ";
- $first = 0;
- if ( $query_type eq 'UPDATE' or $query_type eq 'INSERT' ) {
- push @data, $self->{"$_$linenum"};
- }
- }
- if ( $query_type ne 'INSERT' ) {
- $query =~ s/, $//;
- }
- if ( $query_type eq 'SELECT' ) {
- $query .= " FROM $_";
- }
- if ( $query_type eq 'SELECT' or $query_type eq 'UPDATE' ) {
- $query .= " WHERE row_id = ?";
- }
- if ( $query_type eq 'INSERT' ) {
- $query .= " row_id) VALUES ($ins_values ?)";
- }
- if ( $query_type eq 'SELECT' ) {
- push @rc, [$query];
- }
- else {
- unshift( @data, $query );
- push @rc, ..hidden..;
- }
- }
- if ( $query_type eq 'INSERT' ) {
- for (@rc) {
- $query = shift( @{$_} );
- my $sth = $dbh->prepare($query)
- || $self->db_error($query);
- $sth->execute( @{$_}, $self->{id} )
- || $self->dberror($query);
- $sth->finish;
- $did_insert = 1;
- }
- }
- elsif ( $query_type eq 'UPDATE' ) {
- @rc = $self->run_custom_queries( $tablename, 'INSERT', $linenum );
- }
- elsif ( $query_type eq 'SELECT' ) {
- for (@rc) {
- $query = shift @{$_};
- my $sth = $self->{dbh}->prepare($query);
- $sth->execute( $self->{id} );
- my $ref = $sth->fetchrow_hashref('NAME_lc');
- $self->merge( $ref, keys(%$ref) );
- }
- }
- return @rc;
+ my $self = shift @_;
+ my $dbo = $self->_to_dbobject;
+ return $dbo->run_custom_queries(@_);
}
-sub _parse_array {
- my ($self, $value) = @_;
- return @$value if ref $value eq 'ARRAY';
- return if !defined $value;
- # No longer needed since we require DBD::Pg 2.x
-}
-
-sub _db_array_scalars {
- my $self = shift @_;
- my @args = @_;
- return ..hidden..;
- # No longer needed since we require DBD::Pg 2.x
-}
-
-sub _db_array_literal {
- my $self = shift @_;
- my @args = @_;
- return ..hidden..;
- # No longer needed since we require DBD::Pg 2.x
-}
-
sub call_procedure {
- my $self = shift @_;
- my %args = @_;
- my $procname = $args{procname};
- my $schema = $args{schema};
- my @call_args;
- @call_args = @{ $args{args} } if defined $args{args};
- my $order_by = $args{order_by};
- my $query_rc;
- my $argstr = "";
- my @results;
-
- if (!defined $procname){
- $self->error('Undefined function in call_procedure.');
- }
- $procname = $self->{dbh}->quote_identifier($procname);
- # Add the test for whether the schema is something useful.
- $logger->trace("\$procname=$procname");
-
- $schema = $schema || $LedgerSMB::Sysconfig::db_namespace;
-
- $schema = $self->{dbh}->quote_identifier($schema);
-
- for ( 1 .. scalar @call_args ) {
- $argstr .= "?, ";
- }
- $argstr =~ s/\, $//;
- my $query = "SELECT * FROM $schema.$procname()";
- if ($order_by){
- $query .= " ORDER BY $order_by";
- }
- $query =~ s/\(\)/($argstr)/;
- my $sth = $self->{dbh}->prepare($query);
- my $place = 1;
- # API Change here to support byteas:
- # If the argument is a hashref, allow it to define it's SQL type
- # for example PG_BYTEA, and use that to bind. The API supports the old
- # syntax (array of scalars and arrayrefs) but extends this so that hashrefs
- # now have special meaning. I expect this to be somewhat recursive in the
- # future if hashrefs to complex types are added, but we will have to put
- # that off for another day. --CT
- foreach my $carg (@call_args){
- if (ref($carg) eq 'HASH'){
- $sth->bind_param($place, $carg->{value},
- { pg_type => $carg->{type} });
- } else {
- $sth->bind_param($place, $carg);
- }
- ++$place;
- }
- $query_rc = $sth->execute();
- if (!$query_rc){
- if ($args{continue_on_error} and # only for plpgsql exceptions
- ($self->{dbh}->state =~ /^P/)){
- $@ = $self->{dbh}->errstr;
- } else {
- $self->dberror($self->{dbh}->errstr . ": " . $query);
- }
- }
-
- my @types = @{$sth->{TYPE}};
- my @names = @{$sth->{NAME_lc}};
- while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
- for (0 .. $#names){
- # numeric float4/real
- if ($types[$_] == 3 or $types[$_] == 2) {
- $ref->{$names[$_]} = LedgerSMB::PGNumber->from_db($ref->{$names[$_]});
- }
- # DATE
- elsif ($types[$_] == 91){
- $ref->{$names[$_]} = LedgerSMB::PGDate->from_db($ref->{$names[$_]}, 'date');
- }
- # TIMESTAMP
- elsif ($types[$_] == 11){
- $ref->{$names[$_]} = LedgerSMB::PGDate->from_db($ref->{$names[$_]}, 'datetime');
- }
- }
- push @results, $ref;
- }
- return @results;
+ my $self = shift @_;
+ my $dbo = $self->_to_dbobject;
+ return $dbo->call_procedure(@_);
}
# Keeping this here due to common requirements
sub is_allowed_role {
- my ($self, $args) = @_;
- my @roles = @{$args->{allowed_roles}};
- for my $role (@roles){
- $self->{_role_prefix} = "lsmb_$self->{company}__" unless defined $self->{_role_prefix};
- my @roleset = grep m/^$self->{_role_prefix}$role$/, @{$self->{_roles}};
- if (scalar @roleset){
- return 1;
- }
- }
- return 0;
+ my $self = shift @_;
+ my $dbo = $self->_to_dbobject;
+ return $dbo->is_allowed_role(@_);
}
-# To be replaced with a generic interface to an Error class
-sub error {
-
- my ( $self, $msg ) = @_;
-
- if ( $ENV{GATEWAY_INTERFACE} ) {
-
- $self->{msg} = $msg;
- $self->{format} = "html";
-
- delete $self->{pre};
-
-
- print qq|Content-Type: text/html; charset=utf-8\n\n|;
- print "<head></head>";
- $self->{msg} =~ s/\n/<br \/>\n/;
- print
- qq|<body><h2 class="error">Error!</h2> <p><b>$self->{msg}</b></body>|;
-
- exit;
-
- }
- else {
-
- if ( $ENV{error_function} ) {
- &{ $ENV{error_function} }($msg);
- }
- die "Error: $msg\n";
- }
-}
-# Database routines used throughout
-sub dberror{
- my $self = shift @_;
- my $state_error = {};
- if ($self->{_locale}){
- my $state_error = {
- '42883' => $self->{_locale}->text('Internal Database Error'),
- '42501' => $self->{_locale}->text('Access Denied'),
- '42401' => $self->{_locale}->text('Access Denied'),
- '22008' => $self->{_locale}->text('Invalid date/time entered'),
- '22012' => $self->{_locale}->text('Division by 0 error'),
- '22004' => $self->{_locale}->text('Required input not provided'),
- '23502' => $self->{_locale}->text('Required input not provided'),
- '23505' => $self->{_locale}->text('Conflict with Existing Data'),
- 'P0001' => $self->{_locale}->text('Error from Function:') . "\n" .
- $self->{dbh}->errstr,
- };
- }
- $logger->error("Logging SQL State ".$self->{dbh}->state.", error ".
- $self->{dbh}->err . ", string " .$self->{dbh}->errstr);
- if (defined $state_error->{$self->{dbh}->state}){
- $self->error($state_error->{$self->{dbh}->state}
- . "\n" .
- $self->{_locale}->text('More information has been reported in the error logs'));
- $self->{dbh}->rollback;
- exit;
- }
- $self->error($self->{dbh}->state . ":" . $self->{dbh}->errstr);
-}
-
__PACKAGE__->meta->make_immutable;
1;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.