[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
SF.net SVN: ledger-smb:[6471] trunk/LedgerSMB
- Subject: SF.net SVN: ledger-smb:[6471] trunk/LedgerSMB
- From: ..hidden..
- Date: Thu, 16 Jan 2014 03:53:28 +0000
Revision: 6471
http://sourceforge.net/p/ledger-smb/code/6471
Author: einhverfr
Date: 2014-01-16 03:53:25 +0000 (Thu, 16 Jan 2014)
Log Message:
-----------
Removing a whole slew of pre-1.3 code that isn't used anymore. Most of this code can't work anymore as of 1.3
Modified Paths:
--------------
trunk/LedgerSMB/Form.pm
trunk/LedgerSMB/User.pm
Removed Paths:
-------------
trunk/LedgerSMB/RESTXML/Handler.pm
Modified: trunk/LedgerSMB/Form.pm
===================================================================
--- trunk/LedgerSMB/Form.pm 2014-01-16 02:09:54 UTC (rev 6470)
+++ trunk/LedgerSMB/Form.pm 2014-01-16 03:53:25 UTC (rev 6471)
@@ -1487,65 +1487,6 @@
@rc;
}
-=item $form->dbconnect($myconfig);
-
-Returns an autocommit connection to the database specified in $myconfig.
-
-=cut
-
-sub dbconnect {
-
- my ( $self, $myconfig ) = @_;
-
- # connect to database
- my $dbh = DBI->connect( $myconfig->{dbconnect},
- $myconfig->{dbuser}, $myconfig->{dbpasswd} )
- or $self->dberror;
- $dbh->{pg_enable_utf8} = 1;
-
- # set db options
- if ( $myconfig->{dboptions} ) {
- $dbh->do( $myconfig->{dboptions} )
- || $self->dberror( $myconfig->{dboptions} );
- }
-
- $dbh;
-}
-
-=item $form->dbconnect_noauto($myconfig);
-
-Returns a non-autocommit connection to the database specified in $myconfig.
-
-=cut
-
-sub dbconnect_noauto {
-
- my ( $self, $myconfig ) = @_;
-
- # connect to database
- my $dbh = DBI->connect(
- $myconfig->{dbconnect}, $myconfig->{dbuser},
- $myconfig->{dbpasswd}, { AutoCommit => 0 }
- ) or $self->dberror;
- #HV trying to trace DBI->connect statements
- $logger->debug("DBI->connect dbh=$dbh");
- my $dbi_trace=$LedgerSMB::Sysconfig::DBI_TRACE;
- if($dbi_trace)
- {
- $logger->debug("\$dbi_trace=$dbi_trace");
- $dbh->trace(split /=/,$dbi_trace,2);#http://search.cpan.org/~timb/DBI-1.616/DBI.pm#TRACING
- }
-
- $dbh->{pg_enable_utf8} = 1;
-
- # set db options
- if ( $myconfig->{dboptions} ) {
- $dbh->do( $myconfig->{dboptions} );
- }
-
- $dbh;
-}
-
=item $form->dbquote($var);
If $var is an empty string, return NULL, otherwise return $var as quoted by
Deleted: trunk/LedgerSMB/RESTXML/Handler.pm
===================================================================
--- trunk/LedgerSMB/RESTXML/Handler.pm 2014-01-16 02:09:54 UTC (rev 6470)
+++ trunk/LedgerSMB/RESTXML/Handler.pm 2014-01-16 03:53:25 UTC (rev 6471)
@@ -1,195 +0,0 @@
-
-=head1 NAME
-
-LedgerSMB::RESTXML::Handler - RESTful LSMB API
-
-=cut
-
-package LedgerSMB::RESTXML::Handler;
-use strict;
-use warnings;
-use Carp;
-use LedgerSMB::User;
-use LedgerSMB::Sysconfig;
-use Scalar::Util qw(blessed);
-use DBI;
-
-=head3 cgi_handle
-
-CGI_handle is the gateway for the RESTful lsmb API.
-
-=head3 NOTES
-
-
-=cut
-
-sub cgi_handle {
- my $self = shift;
-
- my $method = $ENV{REQUEST_METHOD};
- my $pathinfo = $ENV{PATH_INFO};
-
- #pull off the leading slash, we need it in the form document/arguments/foo
- $pathinfo =~ s#^/##;
-
- my $function = 'handle_' . lc($method);
- my ( $user, $module, @args ) = split '/', $pathinfo;
- $user = LedgerSMB::User->fetch_config($user);
-
- my $dbh = $self->connect_db($user);
-
- # non-word characters are forbidden, usually a sign of someone being sneaky.
- $module =~ s#\W##;
-
- my $document_module = $self->try_to_load($module);
-
- if ($document_module) {
- if ( $document_module->can($function) ) {
- my $returnValue = $document_module->$function(
- {
- dbh => $dbh,
- args => \@args,
- handler => $self,
- user => $user
- }
- );
-
- #return $self->return_serialized_response($returnValue);
-
- }
- else {
- return $self->unsupported("$module cannot handle method $method");
- }
- }
- else {
- return $self->not_found(
- "Could not find a handler for document type $module: <pre>$@</pre>"
- );
- }
-}
-
-sub cgi_report_error {
- my $self = shift;
- my $message = shift;
- my $code = shift || 500;
-
- print "Status: $code\n";
- print "Content-Type: text/html\n\n";
- print "<html><body>\n";
- print "<h1>REST API error</h1>";
- print "<blockquote>$message</blockquote>";
- print "</body></html>";
-}
-
-sub cgi_read_query {
- my $self = shift;
-
- use CGI::Simple;
- my $cgi = CGI::Simple->new();
-
- return $cgi;
-}
-
-# ------------------------------------------------------------------------------------------------------------------------
-
-=head3 try_to_load
-
-try_to_load will try to load a RESTXML document handler module. returns undef
-if it cannot load the given module for any reason. passed the type of RESTXML
-document to try to load. returns a blessed anonymous hashref if the module
-*can*, and is successfully loaded.
-
-=cut
-
-sub try_to_load {
- my $self = shift;
- my $module = shift;
-
- eval qq{
- use LedgerSMB::RESTXML::Document::$module;
- };
- if ($@) {
- warn "Cannot load $module: $@" unless $@ =~ /Can't locate LedgerSMB\//i;
-
- return undef;
- }
- else {
- return bless {}, "LedgerSMB::RESTXML::Document::$module";
- }
-}
-
-=head3 connect_db
-
-Given a user's config, returns a database connection handle.
-
-=cut
-
-sub connect_db {
- my ( $self, $myconfig ) = @_;
-
- my $dbh = DBI->connect( $myconfig->{dbconnect},
- $myconfig->{dbuser}, $myconfig->{dbpasswd} )
- or carp "Error connecting to the db :$DBI::errstr";
- $dbh->{pg_enable_utf8} = 1;
-
- return $dbh;
-}
-
-# lets see how far XML::Simple can take us.
-use XML::Simple;
-use Scalar::Util qw(blessed);
-
-sub return_serialized_response {
- my ( $self, $response ) = @_;
-
- print "Content-type: text/xml\n\n";
-
- if ( blessed $response && $response->isa('XML::Twig::Elt') ) {
- print qq{<?xml version="1.0"?>\n};
- print $response->sprint();
- }
- else {
- my $xs = XML::Simple->new(
- NoAttr => 1,
- RootName => 'LedgerSMBResponse',
- XMLDecl => 1
- );
-
- print $xs->XMLout($response);
- }
-
- return;
-}
-
-sub read_query {
- my ($self) = @_;
-
- # for now.
- return $self->cgi_read_query();
-}
-
-# =------------------------- POSSIBLE WAYS FOR MODULES TO RESPOND.
-sub respond {
- my ( $self, $data ) = @_;
-
- return $self->return_serialized_response($data);
-}
-
-sub not_found {
- my ( $self, $message ) = @_;
-
- $self->cgi_report_error( $message, 404 );
-}
-
-sub unsupported {
- my ( $self, $message ) = @_;
- $self->cgi_report_error( $message, 501 );
-}
-
-sub error {
- my ( $self, $message ) = @_;
-
- $self->cgi_report_error( $message, 500 );
-}
-
-1;
Modified: trunk/LedgerSMB/User.pm
===================================================================
--- trunk/LedgerSMB/User.pm 2014-01-16 02:09:54 UTC (rev 6470)
+++ trunk/LedgerSMB/User.pm 2014-01-16 03:53:25 UTC (rev 6471)
@@ -64,68 +64,6 @@
my $logger = Log::Log4perl->get_logger('LedgerSMB::User');
-=item LedgerSMB::User->new($login);
-
-Create a LedgerSMB::User object. If the user $login exists, set the fields
-with values retrieved from the database.
-
-=cut
-
-sub new {
-
- my ( $type, $login ) = @_;
- my $self = {};
-
- if ( $login ne "" ) {
-
- # use central db
- my $dbh = ${LedgerSMB::Sysconfig::GLOBALDBH};
-
- # for now, this is querying the table directly... ugly
- my $fetchUserPrefs = $dbh->prepare(
- "SELECT acs, address, businessnumber,
- company, countrycode, currency,
- dateformat, dbdriver, dbhost, dbname,
- dboptions, dbpasswd, dbport, dbuser,
- email, fax, menuwidth, name, numberformat,
- password, print, printer, role, sid,
- signature, stylesheet, tel, templates,
- timeout, vclimit, u.username
- FROM users_conf as uc, users as u
- WHERE u.username = ?
- AND u.id = uc.id;"
- );
-
- $fetchUserPrefs->execute($login);
-
- my $userHashRef = $fetchUserPrefs->fetchrow_hashref;
-
- while ( my ( $key, $value ) = each( %{$userHashRef} ) ) {
- $self->{$key} = $value;
- }
-
- chomp( $self->{dbport} );
- chomp( $self->{dbname} );
- chomp( $self->{dbhost} );
-
- $self->{dbconnect} =
- 'dbi:Pg:dbname='
- . $self->{dbname}
- . ';host='
- . $self->{dbhost}
- . ';port='
- . $self->{dbport};
-
-
-
- if ( $self->{username} ) {
- $self->{login} = $login;
- }
- }
-
- bless $self, $type;
-}
-
=item LedgerSMB::User->country_codes();
Returns a hash where the keys are registered locales and the values are the
@@ -228,797 +166,8 @@
}
-=item LedgerSMB::User::dbconnect_vars($form, $db);
-Converts individual $form values into $form->{dboptions} and $form->{dbconnect}.
-=cut
-
-sub dbconnect_vars {
- my ( $form, $db ) = @_;
-
- my %dboptions = (
- 'Pg' => {
- 'yy-mm-dd' => 'set DateStyle to \'ISO\'',
- 'mm/dd/yy' => 'set DateStyle to \'SQL, US\'',
- 'mm-dd-yy' => 'set DateStyle to \'POSTGRES, US\'',
- 'dd/mm/yy' => 'set DateStyle to \'SQL, EUROPEAN\'',
- 'dd-mm-yy' => 'set DateStyle to \'POSTGRES, EUROPEAN\'',
- 'dd.mm.yy' => 'set DateStyle to \'GERMAN\''
- }
- );
-
- $form->{dboptions} = $dboptions{ $form->{dbdriver} }{ $form->{dateformat} };
-
- $form->{dbconnect} = "dbi:$form->{dbdriver}:dbname=$db";
- $form->{dbconnect} .= ";host=$form->{dbhost}";
- $form->{dbconnect} .= ";port=$form->{dbport}";
-
-}
-
-=item LedgerSMB::User->dbdrivers();
-
-Returns a list of all drivers set up with DBI whose names end in 'Pg'.
-
-=cut
-
-sub dbdrivers {
-
- my @drivers = DBI->available_drivers();
-
- # return (grep { /(Pg|Oracle|DB2)/ } @drivers);
- return ( grep { /Pg$/ } @drivers );
-
-}
-
-=item LedgerSMB::User->dbsources($form);
-
-Returns a list of all databases in the same cluster as the database that $form
-is set to. If $form->{only_acc_db} is set, only non-template databases that
-have a defaults table owned by $form->{dbuser} are returned.
-
-=cut
-
-sub dbsources {
- my ( $self, $form ) = @_;
-
- my @dbsources = ();
- my ( $sth, $query );
-
- $form->{dbdefault} = $form->{dbuser} unless $form->{dbdefault};
- $form->{sid} = $form->{dbdefault};
- &dbconnect_vars( $form, $form->{dbdefault} );
-
- my $dbh =
- DBI->connect( $form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
-
- if ( $form->{dbdriver} eq 'Pg' ) {
-
- $query = qq|SELECT datname FROM pg_database|;
- $sth = $dbh->prepare($query);
- $sth->execute || $form->dberror( __FILE__ . ':' . __LINE__ . $query );
-
- while ( my ($db) = $sth->fetchrow_array ) {
-
- if ( $form->{only_acc_db} ) {
-
- next if ( $db =~ /^template/ );
-
- &dbconnect_vars( $form, $db );
- my $dbh =
- DBI->connect( $form->{dbconnect}, $form->{dbuser},
- $form->{dbpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
-
- $query = qq|
- SELECT tablename FROM pg_tables
- WHERE tablename = 'defaults'
- AND tableowner = ?|;
- my $sth = $dbh->prepare($query);
- $sth->execute( $form->{dbuser} )
- || $form->dberror( __FILE__ . ':' . __LINE__ . $query );
-
- if ( $sth->fetchrow_array ) {
- push @dbsources, $db;
- }
- $sth->finish;
- $dbh->disconnect;
- next;
- }
- push @dbsources, $db;
- }
- }
-
- $sth->finish;
- $dbh->disconnect;
-
- return @dbsources;
-
-}
-
-=item LedgerSMB::User->dbcreate($form);
-
-Create the database indicated by $form->{db} and load Pg-database.sql, the chart
-indicated by $form->{chart} and custom tables and functions
-(Pg-custom_tables.sql and Pg-custom_functions).
-
-=cut
-
-sub dbcreate {
- my ( $self, $form ) = @_;
-
- my %dbcreate =
- ( 'Pg' => qq|CREATE DATABASE "$form->{db}" WITH ENCODING = 'UNICODE'| );
-
- $form->{sid} = $form->{dbdefault};
- &dbconnect_vars( $form, $form->{dbdefault} );
-
- # The below line connects to Template1 or another template file in order
- # to create the db. One must disconnect and reconnect later.
- if ( $form->{dbsuperuser} ) {
- my $superdbh =
- DBI->connect( $form->{dbconnect}, $form->{dbsuperuser},
- $form->{dbsuperpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $superdbh->{pg_enable_utf8} = 1;
- my $query = qq|$dbcreate{$form->{dbdriver}}|;
- $superdbh->do($query)
- || $form->dberror( __FILE__ . ':' . __LINE__ . $query );
-
- $superdbh->disconnect;
- }
-
- #Reassign for the work below
-
- &dbconnect_vars( $form, $form->{db} );
-
- my $dbh =
- DBI->connect( $form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
- if ( $form->{dbsuperuser} ) {
- my $superdbh =
- DBI->connect( $form->{dbconnect}, $form->{dbsuperuser},
- $form->{dbsuperpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $superdbh->{pg_enable_utf8} = 1;
-
- # JD: We need to check for plpgsql,
- # if it isn't there create it, if we can't error
- # Good chance I will have to do this twice as I get
- # used to the way the code is structured
-
- my %langcreate = ( 'Pg' => qq|CREATE LANGUAGE plpgsql| );
- my $query = qq|$langcreate{$form->{dbdriver}}|;
- $superdbh->do($query);
- $superdbh->disconnect;
- }
-
- # create the tables
- my $dbdriver =
- ( $form->{dbdriver} =~ /Pg/ )
- ? 'Pg'
- : $form->{dbdriver};
-
- my $filename = qq|sql/Pg-database.sql|;
- $self->process_query( $form, $dbh, $filename );
-
- # load gifi
- ($filename) = split /_/, $form->{chart};
- $filename =~ s/_//;
- $self->process_query( $form, $dbh, "sql/${filename}-gifi.sql" );
-
- # load chart of accounts
- $filename = qq|sql/$form->{chart}-chart.sql|;
- $self->process_query( $form, $dbh, $filename );
-
- # create custom tables and functions
- my $item;
- foreach $item (qw(tables functions)) {
- $filename = "sql/${dbdriver}-custom_${item}.sql";
- if ( -f "$filename" ) {
- $self->process_query( $form, $dbh, $filename );
- }
- }
-
- $dbh->disconnect;
-
-}
-
-=item LedgerSMB::User->process_query($form, $dbh, $filename);
-
-Load the file $filename into the database indicated through form using psql.
-$dbh is ignored.
-
-=cut
-
-sub process_query {
- my ( $self, $form, $dbh, $filename ) = @_;
-
- return unless ( -f $filename );
-
- $ENV{PGPASSWORD} = $form->{dbpasswd};
- $ENV{PGUSER} = $form->{dbuser};
- $ENV{PGDATABASE} = $form->{db};
- $ENV{PGHOST} = $form->{dbhost};
- $ENV{PGPORT} = $form->{dbport};
-
- $results = `psql -f $filename 2>&1`;
- if ($?) {
- $form->error($!);
- }
- elsif ( $results =~ /error/i ) {
- $form->error($results);
- }
-}
-
-=item LedgerSMB::User->dbdelete($form);
-
-Disused function to drop the database $form->{db}.
-
-=cut
-
-sub dbdelete {
- my ( $self, $form ) = @_;
-
- $form->{sid} = $form->{dbdefault};
- &dbconnect_vars( $form, $form->{dbdefault} );
- my $dbh =
- DBI->connect( $form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
- my $query = qq|DROP DATABASE "$form->{db}"|;
- $dbh->do($query) || $form->dberror( __FILE__ . ':' . __LINE__ . $query );
-
- $dbh->disconnect;
-
-}
-
-=item LedgerSMB::User->dbsources_unused($form, $memfile);
-
-Disused function to identify all databases in a cluster with a defaults table
-that are not mentioned in the memberfile $memfile.
-
-=cut
-
-sub dbsources_unused {
- my ( $self, $form, $memfile ) = @_;
-
- my @dbexcl = ();
- my @dbsources = ();
-
- $form->error( __FILE__ . ':' . __LINE__ . ": $memfile locked!" )
- if ( -f "${memfile}.LCK" );
-
- # open members file
- open( FH, '<', "$memfile" )
- or $form->error( __FILE__ . ':' . __LINE__ . ": $memfile : $!" );
-
- while (<FH>) {
- if (/^dbname=/) {
- my ( $null, $item ) = split /=/;
- push @dbexcl, $item;
- }
- }
-
- close FH;
-
- $form->{only_acc_db} = 1;
- my @db = &dbsources( "", $form );
-
- push @dbexcl, $form->{dbdefault};
-
- foreach $item (@db) {
- unless ( grep /$item$/, @dbexcl ) {
- push @dbsources, $item;
- }
- }
-
- return @dbsources;
-
-}
-
-=item LedgerSMB::User->dbneedsupdate($form);
-
-Disused function to locate all databases owned by $form->{dbuser} that are not
-a template* database which have a defaults table with a version entry.
-
-=cut
-
-sub dbneedsupdate {
- my ( $self, $form ) = @_;
-
- my %dbsources = ();
- my $query;
-
- $form->{sid} = $form->{dbdefault};
- &dbconnect_vars( $form, $form->{dbdefault} );
-
- my $dbh =
- DBI->connect( $form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
-
- if ( $form->{dbdriver} =~ /Pg/ ) {
-
- $query = qq|
- SELECT d.datname
- FROM pg_database d, pg_user u
- WHERE d.datdba = u.usesysid
- AND u.usename = ?|;
- my $sth = $dbh->prepare($query);
- $sth->execute( $form->{dbuser} )
- || $form->dberror( __FILE__ . ':' . __LINE__ . $query );
-
- while ( my ($db) = $sth->fetchrow_array ) {
-
- next if ( $db =~ /^template/ );
-
- &dbconnect_vars( $form, $db );
-
- my $dbh =
- DBI->connect( $form->{dbconnect}, $form->{dbuser},
- $form->{dbpasswd} )
- or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
-
- $query = qq|
- SELECT tablename
- FROM pg_tables
- WHERE tablename = 'defaults'|;
- my $sth = $dbh->prepare($query);
- $sth->execute
- || $form->dberror( __FILE__ . ':' . __LINE__ . $query );
-
- if ( $sth->fetchrow_array ) {
- $query = qq|
- SELECT value FROM defaults
- WHERE setting_key = 'version'|;
- my $sth = $dbh->prepare($query);
- $sth->execute;
-
- if ( my ($version) = $sth->fetchrow_array ) {
- $dbsources{$db} = $version;
- }
- $sth->finish;
- }
- $sth->finish;
- $dbh->disconnect;
- }
- $sth->finish;
- }
-
- $dbh->disconnect;
-
- %dbsources;
-
-}
-
-=item LedgerSMB::User->dbupdate($form);
-
-Applies database upgrade scripts to upgrade the database to the current level.
-
-=cut
-
-sub dbupdate {
- my ( $self, $form ) = @_;
-
- $form->{sid} = $form->{dbdefault};
-
- my @upgradescripts = ();
- my $query;
- my $rc = -2;
-
- if ( $form->{dbupdate} ) {
-
- # read update scripts into memory
- opendir SQLDIR, "sql/."
- or $form->error( __FILE__ . ':' . __LINE__ . ': ' . $! );
- @upgradescripts =
- sort script_version grep /$form->{dbdriver}-upgrade-.*?\.sql$/,
- readdir SQLDIR;
- closedir SQLDIR;
- }
-
- foreach my $db ( split / /, $form->{dbupdate} ) {
-
- next unless $form->{$db};
-
- # strip db from dataset
- $db =~ s/^db//;
- &dbconnect_vars( $form, $db );
-
- my $dbh = DBI->connect(
- $form->{dbconnect}, $form->{dbuser},
- $form->{dbpasswd}, { AutoCommit => 0 }
- ) or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
-
- # check version
- $query = qq|
- SELECT value FROM defaults
- WHERE setting_key = 'version'|;
- my $sth = $dbh->prepare($query);
-
- # no error check, let it fall through
- $sth->execute;
-
- my $version = $sth->fetchrow_array;
- $sth->finish;
-
- next unless $version;
-
- $version = calc_version($version);
- my $dbversion = calc_version( $form->{dbversion} );
-
- foreach my $upgradescript (@upgradescripts) {
- my $a = $upgradescript;
- $a =~ s/(^$form->{dbdriver}-upgrade-|\.sql$)//g;
-
- my ( $mindb, $maxdb ) = split /-/, $a;
- $mindb = calc_version($mindb);
- $maxdb = calc_version($maxdb);
-
- next if ( $version >= $maxdb );
-
- # exit if there is no upgrade script or version == mindb
- last if ( $version < $mindb || $version >= $dbversion );
-
- # apply upgrade
- $self->process_query( $form, $dbh, "sql/$upgradescript" );
- $dbh->commit;
- $version = $maxdb;
-
- }
-
- $rc = 0;
- $dbh->disconnect;
-
- }
-
- $rc;
-
-}
-
-=item calc_version($version);
-
-Returns a numeric form for the version passed in. The numeric form is derived
-by converting each dotted portion of the version to a three-digit number and
-appending them.
-
- +----------+------------+
- | $version | returned |
- +----------+------------+
- | 1.0.0 | 1000000 |
- | 1.2.33 | 1002033 |
- | 189.2.33 | 189002033 |
- | 1.2.3.4 | 1002003004 |
- +----------+------------+
-
-=cut
-
-sub calc_version {
-
- my @v = split /\./, $_[0];
- my $version = 0;
- my $i;
-
- for ( $i = 0 ; $i <= $#v ; $i++ ) {
- $version *= 1000;
- $version += $v[$i];
- }
-
- return $version;
-
-}
-
-=item script_version
-
-Sorting function for database upgrade scripts.
-
-=cut
-
-sub script_version {
- my ( $my_a, $my_b ) = ( $a, $b );
-
- my ( $a_from, $a_to, $b_from, $b_to );
- my ( $res_a, $res_b, $i );
-
- $my_a =~ s/.*-upgrade-//;
- $my_a =~ s/.sql$//;
- $my_b =~ s/.*-upgrade-//;
- $my_b =~ s/.sql$//;
- ( $a_from, $a_to ) = split( /-/, $my_a );
- ( $b_from, $b_to ) = split( /-/, $my_b );
-
- $res_a = calc_version($a_from);
- $res_b = calc_version($b_from);
-
- if ( $res_a == $res_b ) {
- $res_a = calc_version($a_to);
- $res_b = calc_version($b_to);
- }
-
- return $res_a <=> $res_b;
-
-}
-
-=item $user->save_member();
-
-Updates the user config in the database for the user $user. If no config for
-the user exists, the user to the database.
-
-=cut
-
-sub save_member {
-
- my ($self) = @_;
-
- # replace \r\n with \n
- for (qw(address signature)) { $self->{$_} =~ s/\r?\n/\\n/g }
-
- # use central db
- my $dbh = ${LedgerSMB::Sysconfig::GLOBALDBH};
-
- #check to see if the user exists already
- my $userCheck = $dbh->prepare("SELECT id FROM users WHERE username = ?");
- $userCheck->execute( $self->{login} );
- my ($userID) = $userCheck->fetchrow_array;
-
- if ( !$self->{dbhost} ) {
- $self->{dbhost} = 'localhost';
- }
- if ( !$self->{dbport} ) {
- $self->{dbport} = '5432';
- }
-
- my $userConfExists = 0;
-
- if ($userID) {
-
- #got an id, check to see if it's in the users_conf table
- my $userConfCheck =
- $dbh->prepare("SELECT password, 1 FROM users_conf WHERE id = ?");
- $userConfCheck->execute($userID);
-
- ( $oldPassword, $userConfExists ) = $userConfCheck->fetchrow_array;
- }
- else {
- my $userConfAdd = $dbh->prepare("SELECT create_user(?);");
- $userConfAdd->execute( $self->{login} );
- ($userID) = $userConfAdd->fetchrow_array;
- }
-
- if ($userConfExists) {
-
- # for now, this is updating the table directly... ugly
- my $userConfUpdate = $dbh->prepare(
- "UPDATE users_conf
- SET acs = ?, address = ?, businessnumber = ?,
- company = ?, countrycode = ?, currency = ?,
- dateformat = ?, dbdriver = ?,
- dbhost = ?, dbname = ?, dboptions = ?,
- dbpasswd = ?, dbport = ?, dbuser = ?,
- email = ?, fax = ?, menuwidth = ?,
- name = ?, numberformat = ?,
- print = ?, printer = ?, role = ?,
- sid = ?, signature = ?, stylesheet = ?,
- tel = ?, templates = ?, timeout = ?,
- vclimit = ?
- WHERE id = ?;"
- );
-
- $userConfUpdate->execute(
- $self->{acs}, $self->{address},
- $self->{businessnumber}, $self->{company},
- $self->{countrycode}, $self->{currency},
- $self->{dateformat}, $self->{dbdriver},
- $self->{dbhost}, $self->{dbname},
- $self->{dboptions}, $self->{dbpasswd},
- $self->{dbport}, $self->{dbuser},
- $self->{email}, $self->{fax},
- $self->{menuwidth}, $self->{name},
- $self->{numberformat}, $self->{print},
- $self->{printer}, $self->{role},
- $self->{sid}, $self->{signature},
- $self->{stylesheet}, $self->{tel},
- $self->{templates}, $self->{timeout},
- $self->{vclimit}, $userID
- );
-
- if ( $oldPassword ne $self->{password} ) {
-
- # if they're supplying a 32 char password that matches their old password
- # assume they don't want to change passwords
-
- $userConfUpdate = $dbh->prepare(
- "UPDATE users_conf
- SET password = md5(?)
- WHERE id = ?"
- );
-
- $userConfUpdate->execute( $self->{password}, $userID );
-
- }
-
- }
- else {
-
- my $userConfInsert = $dbh->prepare(
- "INSERT INTO users_conf(acs, address, businessnumber,
- company, countrycode, currency,
- dateformat, dbdriver,
- dbhost, dbname, dboptions, dbpasswd,
- dbport, dbuser, email, fax, menuwidth,
- name, numberformat, print, printer, role,
- sid, signature, stylesheet, tel, templates,
- timeout, vclimit, id, password)
- VALUES(?, ?, ?, ?, ?, ?, ?, ?, ?, ?,
- ?, ?, ?, ?, ?, ?, ?, ?, ?, ?,
- ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, md5(?));"
- );
-
- $userConfInsert->execute(
- $self->{acs}, $self->{address},
- $self->{businessnumber}, $self->{company},
- $self->{countrycode}, $self->{currency},
- $self->{dateformat}, $self->{dbdriver},
- $self->{dbhost}, $self->{dbname},
- $self->{dboptions}, $self->{dbpasswd},
- $self->{dbport}, $self->{dbuser},
- $self->{email}, $self->{fax},
- $self->{menuwidth}, $self->{name},
- $self->{numberformat}, $self->{print},
- $self->{printer}, $self->{role},
- $self->{sid}, $self->{signature},
- $self->{stylesheet}, $self->{tel},
- $self->{templates}, $self->{timeout},
- $self->{vclimit}, $userID,
- $self->{password}
- );
-
- }
-
- if ( !$self->{'admin'} ) {
-
- $self->{dbpasswd} =~ s/\\'/'/g;
- $self->{dbpasswd} =~ s/\\\\/\\/g;
-
- # format dbconnect and dboptions string
- &dbconnect_vars( $self, $self->{dbname} );
-
- # check if login is in database
- my $dbh = DBI->connect(
- $self->{dbconnect}, $self->{dbuser},
- $self->{dbpasswd}, { AutoCommit => 0 }
- ) or $self->error($DBI::errstr);
- $dbh->{pg_enable_utf8} = 1;
-
- # add login to employees table if it does not exist
- my $login = $self->{login};
- $login =~ s/@.*//;
- my $sth = $dbh->prepare("SELECT entity_id FROM employee WHERE login = ?;");
- $sth->execute($login);
-
- my ($id) = $sth->fetchrow_array;
- $sth->finish;
- my $employeenumber;
- my @values;
- if ($id) {
-
- $query = qq|UPDATE employee SET
- role = ?,
- email = ?,
- name = ?
- WHERE login = ?|;
-
- @values = ( $self->{role}, $self->{email}, $self->{name}, $login );
-
- }
- else {
-
- my ($employeenumber) =
- Form::update_defaults( "", \%$self, "employeenumber", $dbh );
- $query = qq|
- INSERT INTO employee
- (login, employeenumber, name,
- workphone, role, email, sales)
- VALUES (?, ?, ?, ?, ?, ?, '1')|;
-
- @values = (
- $login, $employeenumber, $self->{name},
- $self->{tel}, $self->{role}, $self->{email}
- );
- }
-
- $sth = $dbh->prepare($query);
- $sth->execute(@values);
- $dbh->commit;
- $dbh->disconnect;
-
- }
-}
-
-=item LedgerSMB::User->delete_login($form);
-
-Disused function to delete the user $form->{login}.
-
-=cut
-
-sub delete_login {
- my ( $self, $form ) = @_;
-
- my $dbh = DBI->connect(
- $form->{dbconnect}, $form->{dbuser},
- $form->{dbpasswd}, { AutoCommit => 0 }
- ) or $form->dberror( __FILE__ . ':' . __LINE__ );
- $dbh->{pg_enable_utf8} = 1;
-
- my $login = $form->{login};
- $login =~ s/@.*//;
- my $query = qq|SELECT entity_id FROM employee WHERE login = ?|;
- my $sth = $dbh->prepare($query);
- $sth->execute($login)
- || $form->dberror( __FILE__ . ':' . __LINE__ . ': ' . $query );
-
- my ($id) = $sth->fetchrow_array;
- $sth->finish;
-
- $query = qq|
- UPDATE employee
- SET login = NULL,
- enddate = current_date
- WHERE login = ?|;
- $sth = $dbh->prepare($query);
- $sth->execute($login);
- $dbh->commit;
- $dbh->disconnect;
-
-}
-
-=item LedgerSMB::User->config_vars();
-
-Disused function that returns a list of user config variable names.
-
-=cut
-
-sub config_vars {
-
- my @conf = qw(acs address businessnumber company countrycode
- currency dateformat dbconnect dbdriver dbhost dbname dboptions
- dbpasswd dbport dbuser email fax menuwidth name numberformat
- password printer role sid signature stylesheet tel templates
- timeout vclimit);
-
- @conf;
-
-}
-
-=item $self->error($msg);
-
-Privately used error function. Used in places where the more typically used
-$form->error cannot be used. Always dies.
-
-=cut
-
-sub error {
- my ( $self, $msg ) = @_;
-
- if ( $ENV{GATEWAY_INTERFACE} ) {
- print qq|Content-Type: text/html\n\n|
- . qq|<body bgcolor=ffffff>\n\n|
- . qq|<h2><font color=red>Error!</font></h2>\n|
- . qq|<p><b>$msg</b>|;
-
- }
-
- die "Error: $msg\n";
-
-}
-
1;
=back
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
------------------------------------------------------------------------------
CenturyLink Cloud: The Leader in Enterprise Cloud Services.
Learn Why More Businesses Are Choosing CenturyLink Cloud For
Critical Workloads, Development Environments & Everything In Between.
Get a Quote or Start a Free Trial Today.
http://pubads.g.doubleclick.net/gampad/clk?id=119420431&iu=/4140/ostg.clktrk
_______________________________________________
Ledger-smb-commits mailing list
..hidden..
https://lists.sourceforge.net/lists/listinfo/ledger-smb-commits