Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100755 598 lines (480 sloc) 15.769 kB
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
1
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
2 =head1 NAME
3
fa02f0b Updated LedgerSMB.pm
einhverfr authored
4 LedgerSMB The Base class for many LedgerSMB objects, including DBObject.
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
5
54f9a9f Adding pod to Locale.pm
tetragon authored
6 =head1 SYNOPSIS
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
7
fa02f0b Updated LedgerSMB.pm
einhverfr authored
8 This module creates a basic request handler with utility functions available
9 in database objects (LedgerSMB::DBObject)
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
10
11 =head1 METHODS
12
13 =item new ()
14 This method creates a new base request instance.
15
b058034 Adding ledgersmb.conf.default
einhverfr authored
16 =item date_to_number (user => $LedgerSMB::User, date => $string);
17 This function takes the date in the format provided and returns a numeric
18 string in YYMMDD format. This may be moved to User in the future.
19
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
20 =item debug (file => $path);
21
22 This dumps the current object to the file if that is defined and otherwise to
23 standard output.
24
25 =item escape (string => $string);
26
27 This function returns the current string escaped using %hexhex notation.
28
29 =item unescape (string => $string);
30
31 This function returns the $string encoded using %hexhex using ordinary notation.
32
fa02f0b Updated LedgerSMB.pm
einhverfr authored
33 =item format_amount (user => $LedgerSMB::User::hash, amount => $string, precision => $integer, neg_format => (-|DRCR));
34
35 The function takes a monetary amount and formats it according to the user
b058034 Adding ledgersmb.conf.default
einhverfr authored
36 preferences, the negative format (- or DR/CR). Note that it may move to
37 LedgerSMB::User at some point in the future.
38
39 =item parse_amount (user => $LedgerSMB::User::hash, amount => $variable);
40 If $amount is a Bigfloat, it is returned as is. If it is a string, it is
41 parsed according to the user preferences stored in the LedgerSMB::User object.
fa02f0b Updated LedgerSMB.pm
einhverfr authored
42
adf7a85 LedgerSMB::redo_rows is broken for now but unused. All functions in …
einhverfr authored
43 =item is_blank (name => $string)
44 This function returns true if $self->{$string} only consists of whitespace
45 characters or is an empty string.
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
46
119f418 Added LedgerSMB::is_run_mode
einhverfr authored
47 =item is_run_mode ('(cli|cgi|mod_perl)')
48 This function returns 1 if the run mode is what is specified. Otherwise
49 returns 0.
50
dcfdaee Adding role checking function for UI use
einhverfr authored
51 =item is_allowed_role(allowed_roles => @role_names)
52 This function returns 1 if the user's roles include any of the roles in
53 @role_names. Currently it returns 1 when this is not found as well but when
54 role permissions are introduced, this will change to 0.
55
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
56 =item num_text_rows (string => $string, cols => $number, max => $number);
57
58 This function determines the likely number of rows needed to hold text in a
59 textbox. It returns either that number or max, which ever is lower.
60
7555d49 Mostly done rewriting LedgerSMB.pm. There are a few areas that still…
einhverfr authored
61 =item merge ($hashref, keys => @list, index => $number);
62 This command merges the $hashref into the current object. If keys are
63 specified, only those keys are used. Otherwise all keys are merged.
64
65 If an index is specified, the merged keys are given a form of
66 "$key" . "_$index", otherwise the key is used on both sides.
67
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
68 =item redirect (msg => $string)
69
70 This function redirects to the script and argument set determined by
71 $self->{callback}, and if this is not set, goes to an info screen and prints
72 $msg.
73
547e6b5 Adding completed LedgerSMB::redo_rows
einhverfr authored
74 =item redo_rows (fields => \@list, count => $integer, [index => $string);
75 This function is undergoing serious redesign at the moment. If index is
76 defined, that field is used for ordering the rows. If not, runningnumber is
ade3672 Moved LedgerSMB::new to use CGI.pm for parameter parsing.
einhverfr authored
77 used. Behavior is not defined when index points to a field containing
78 non-numbers.
7555d49 Mostly done rewriting LedgerSMB.pm. There are a few areas that still…
einhverfr authored
79
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
80 =head1 Copyright (C) 2006, The LedgerSMB core team.
81
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
82 # This work contains copyrighted information from a number of sources all used
83 # with permission.
84 #
85 # This file contains source code included with or based on SQL-Ledger which
86 # is Copyright Dieter Simader and DWS Systems Inc. 2000-2005 and licensed
87 # under the GNU General Public License version 2 or, at your option, any later
88 # version. For a full list including contact information of contributors,
89 # maintainers, and copyright holders, see the CONTRIBUTORS file.
90 #
91 # Original Copyright Notice from SQL-Ledger 2.6.17 (before the fork):
92 # Copyright (C) 2000
93 #
94 # Author: DWS Systems Inc.
95 # Web: http://www.sql-ledger.org
96 #
97 # Contributors: Thomas Bayen <bayen@gmx.de>
98 # Antti Kaihola <akaihola@siba.fi>
99 # Moritz Bunkus (tex)
100 # Jim Rawlings <jim@your-dba.com> (DB2)
101 #======================================================================
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
102 =cut
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
103
ade3672 Moved LedgerSMB::new to use CGI.pm for parameter parsing.
einhverfr authored
104 use CGI;
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
105 use Math::BigFloat lib => 'GMP';
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
106 use LedgerSMB::Sysconfig;
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
107 use Data::Dumper;
665470f LedgerSMB.pm now uses strict
einhverfr authored
108 use strict;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
109
110 package LedgerSMB;
111
112 sub new {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
113 my $type = shift @_;
114 my $argstr = shift @_;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
115
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
116 my $self = {};
117 $self->{version} = "1.3.0 Alpha 0 Pre";
118 $self->{dbversion} = "1.2.0";
119 bless $self, $type;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
120
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
121 my $query = ($argstr) ? new CGI($argstr) : new CGI;
122 my $params = $query->Vars;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
123
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
124 $self->merge($params);
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
125
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
126 $self->{action} =~ s/\W/_/g;
127 $self->{action} = lc $self->{action};
0af29a7 Removing executable bit from documentation
einhverfr authored
128
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
129 if ( $self->{path} eq "bin/lynx" ) {
130 $self->{menubar} = 1;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
131
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
132 #menubar will be deprecated, replaced with below
133 $self->{lynx} = 1;
134 $self->{path} = "bin/lynx";
135 }
136 else {
137 $self->{path} = "bin/mozilla";
0af29a7 Removing executable bit from documentation
einhverfr authored
138
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
139 }
5ac924a Renamed images to ledgersmb*
einhverfr authored
140
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
141 if ( ( $self->{script} =~ m#(..|\\|/)# ) ) {
142 $self->error("Access Denied");
143 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
144
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
145 $self;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
146
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
147 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
148
149 sub debug {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
150 my $self = shift @_;
151 my %args = @_;
152 my $file = $args{file};
153 my $d = Data::Dumper->new( [@_] );
154 $d->Sortkeys(1);
155
156 if ($file) {
157 open( FH, '>', "$file" ) or die $!;
158 print FH $d->Dump();
159 close(FH);
160 }
161 else {
162 print "\n";
163 print $d->Dump();
164 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
165
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
166 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
167
168 sub escape {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
169 my ($self) = @_;
170 my %args = @_;
171 my $str = $args{string};
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
172
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
173 my $regex = qr/([^a-zA-Z0-9_.-])/;
174 $str =~ s/$regex/sprintf("%%%02x", ord($1))/ge;
175 $str;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
176 }
177
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
178 sub is_blank {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
179 my $self = shift @_;
180 my %args = @_;
181 my $name = $args{name};
5e02607 Adding missing arg logic stub for LedgerSMB.pm
einhverfr authored
182 if (not defined $name){
183 # TODO: Raise error
184 }
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
185 my $rc;
186 if ( $self->{$name} =~ /^\s*$/ ) {
187 $rc = 1;
188 }
189 else {
190 $rc = 0;
191 }
192 $rc;
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
193 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
194
119f418 Added LedgerSMB::is_run_mode
einhverfr authored
195 sub is_run_mode {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
196 my $self = shift @_;
197 my $mode = lc shift @_;
198 my $rc = 0;
199 if ( $mode eq 'cgi' && $ENV{GATEWAY_INTERFACE} ) {
200 $rc = 1;
201 }
202 elsif ( $mode eq 'cli' && !( $ENV{GATEWAY_INTERFACE} || $ENV{MOD_PERL} ) ) {
203 $rc = 1;
204 }
205 elsif ( $mode eq 'mod_perl' && $ENV{MOD_PERL} ) {
206 $rc = 1;
207 }
208 $rc;
119f418 Added LedgerSMB::is_run_mode
einhverfr authored
209 }
210
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
211 sub num_text_rows {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
212 my $self = shift @_;
213 my %args = @_;
214 my $string = $args{string};
215 my $cols = $args{cols};
216 my $maxrows = $args{max};
217
218 my $rows = 0;
219
220 for ( split /\n/, $string ) {
221 my $line = $_;
222 while ( length($line) > $cols ) {
223 my $fragment = substr( $line, 0, $cols + 1 );
224 my $fragment = s/^(.*)\S*$/$1/;
225 $line = s/$fragment//;
226 if ( $line eq $fragment ) { # No word breaks!
227 $line = "";
228 }
229 ++$rows;
230 }
231 ++$rows;
232 }
233
234 if ( !defined $maxrows ) {
235 $maxrows = $rows;
236 }
237
238 return ( $rows > $maxrows ) ? $maxrows : $rows;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
239
240 }
241
242 sub redirect {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
243 my $self = shift @_;
244 my %args = @_;
245 my $msg = $args{msg};
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
246
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
247 if ( $self->{callback} || !$msg ) {
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
248
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
249 main::redirect();
250 }
251 else {
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
252
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
253 $self->info($msg);
254 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
255 }
256
fa02f0b Updated LedgerSMB.pm
einhverfr authored
257 # TODO: Either we should have an amount class with formats and such attached
258 # Or maybe we should move this into the user class...
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
259 sub format_amount {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
260
261 # Based on SQL-Ledger's Form::format_amount
262 my $self = shift @_;
263 my %args = @_;
264 my $myconfig = $args{user};
265 my $amount = $args{amount};
266 my $places = $args{precision};
267 my $dash = $args{neg_format};
268
269 my $negative;
270 if ($amount) {
271 $amount = $self->parse_amount( $myconfig, $amount );
272 $negative = ( $amount < 0 );
273 $amount =~ s/-//;
274 }
275
276 if ( $places =~ /\d+/ ) {
277
278 #$places = 4 if $places == 2;
279 $amount = $self->round_amount( $amount, $places );
280 }
281
282 # is the amount negative
283
284 # Parse $myconfig->{numberformat}
285
286 my ( $ts, $ds ) = ( $1, $2 );
287
288 if ($amount) {
289
290 if ( $myconfig->{numberformat} ) {
291
292 my ( $whole, $dec ) = split /\./, "$amount";
293 $amount = join '', reverse split //, $whole;
294
295 if ($places) {
296 $dec .= "0" x $places;
297 $dec = substr( $dec, 0, $places );
298 }
299
300 if ( $myconfig->{numberformat} eq '1,000.00' ) {
301 $amount =~ s/\d{3,}?/$&,/g;
302 $amount =~ s/,$//;
303 $amount = join '', reverse split //, $amount;
304 $amount .= "\.$dec" if ( $dec ne "" );
305 }
306
307 if ( $myconfig->{numberformat} eq '1 000.00' ) {
308 $amount =~ s/\d{3,}?/$& /g;
309 $amount =~ s/\s$//;
310 $amount = join '', reverse split //, $amount;
311 $amount .= "\.$dec" if ( $dec ne "" );
312 }
313
314 if ( $myconfig->{numberformat} eq "1'000.00" ) {
315 $amount =~ s/\d{3,}?/$&'/g;
316 $amount =~ s/'$//;
317 $amount = join '', reverse split //, $amount;
318 $amount .= "\.$dec" if ( $dec ne "" );
319 }
320
321 if ( $myconfig->{numberformat} eq '1.000,00' ) {
322 $amount =~ s/\d{3,}?/$&./g;
323 $amount =~ s/\.$//;
324 $amount = join '', reverse split //, $amount;
325 $amount .= ",$dec" if ( $dec ne "" );
326 }
327
328 if ( $myconfig->{numberformat} eq '1000,00' ) {
329 $amount = "$whole";
330 $amount .= ",$dec" if ( $dec ne "" );
331 }
332
333 if ( $myconfig->{numberformat} eq '1000.00' ) {
334 $amount = "$whole";
335 $amount .= ".$dec" if ( $dec ne "" );
336 }
337
338 if ( $dash =~ /-/ ) {
339 $amount = ($negative) ? "($amount)" : "$amount";
340 }
341 elsif ( $dash =~ /DRCR/ ) {
342 $amount = ($negative) ? "$amount DR" : "$amount CR";
343 }
344 else {
345 $amount = ($negative) ? "-$amount" : "$amount";
346 }
347 }
348
349 }
350 else {
351
352 if ( $dash eq "0" && $places ) {
353
354 if ( $myconfig->{numberformat} eq '1.000,00' ) {
355 $amount = "0" . "," . "0" x $places;
356 }
357 else {
358 $amount = "0" . "." . "0" x $places;
359 }
360
361 }
362 else {
363 $amount = ( $dash ne "" ) ? "$dash" : "";
364 }
365 }
366
367 $amount;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
368 }
369
b058034 Adding ledgersmb.conf.default
einhverfr authored
370 # This should probably go to the User object too.
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
371 sub parse_amount {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
372 my $self = shift @_;
373 my %args = @_;
374 my $myconfig = $args{user};
375 my $amount = $args{amount};
376
377 if ( $amount eq '' or $amount == undef ) {
378 return 0;
379 }
380
381 if ( UNIVERSAL::isa( $amount, 'Math::BigFloat' ) )
382 { # Amount may not be an object
383 return $amount;
384 }
385 my $numberformat = $myconfig->{numberformat};
386
387 if ( ( $numberformat eq '1.000,00' )
388 || ( $numberformat eq '1000,00' ) )
389 {
390
391 $amount =~ s/\.//g;
392 $amount =~ s/,/./;
393 }
394 if ( $numberformat eq '1 000.00' ) {
395 $amount =~ s/\s//g;
396 }
397
398 if ( $numberformat eq "1'000.00" ) {
399 $amount =~ s/'//g;
400 }
401
402 $amount =~ s/,//g;
403 if ( $amount =~ s/\((\d*\.?\d*)\)/$1/ ) {
404 $amount = $1 * -1;
405 }
406 if ( $amount =~ s/(\d*\.?\d*)\s?DR/$1/ ) {
407 $amount = $1 * -1;
408 }
409 $amount =~ s/\s?CR//;
410 $amount = new Math::BigFloat($amount);
411 return ( $amount * 1 );
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
412 }
413
414 sub round_amount {
415
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
416 my ( $self, $amount, $places ) = @_;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
417
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
418 # These rounding rules follow from the previous implementation.
419 # They should be changed to allow different rules for different accounts.
420 Math::BigFloat->round_mode('+inf') if $amount >= 0;
421 Math::BigFloat->round_mode('-inf') if $amount < 0;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
422
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
423 $amount = Math::BigFloat->new($amount)->ffround( -$places ) if $places >= 0;
424 $amount = Math::BigFloat->new($amount)->ffround( -( $places - 1 ) )
425 if $places < 0;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
426
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
427 return $amount;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
428 }
429
6241ff6 renamed LedgerSMB::callproc to call_procedure. Reworked a number of …
einhverfr authored
430 sub call_procedure {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
431 my $self = shift @_;
432 my %args = @_;
433 my $procname = $args{procname};
434 my @args = @{ $args{args} };
2aa9246 Added stored procedure collation handling stub
einhverfr authored
435 my $order_by = $args{order_by};
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
436 my $argstr = "";
437 my @results;
438 for ( 1 .. scalar @args ) {
439 $argstr .= "?, ";
440 }
441 $argstr =~ s/\, $//;
442 my $query = "SELECT * FROM $procname()";
2aa9246 Added stored procedure collation handling stub
einhverfr authored
443 if ($order_by){
444 $query .= " ORDER BY $order_by";
445 }
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
446 $query =~ s/\(\)/($argstr)/;
447 my $sth = $self->{dbh}->prepare($query);
448 $sth->execute(@args);
345edc3 Adding type detection so that NUMERIC types from the db are handed of…
einhverfr authored
449 my @types = @{$sth->{TYPE}};
450 my @names = @{$sth->{NAME_lc}};
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
451 while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
345edc3 Adding type detection so that NUMERIC types from the db are handed of…
einhverfr authored
452 for (0 .. $#names){
19b819c Applying patch to bugs 1699718 and 1713439
einhverfr authored
453 if ($types[$_] == 3){
345edc3 Adding type detection so that NUMERIC types from the db are handed of…
einhverfr authored
454 $ref->{$names[$_]} = Math::BigFloat->new($ref->{$names[$_]});
455 }
456 }
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
457 push @results, $ref;
458 }
459 @results;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
460 }
461
dcfdaee Adding role checking function for UI use
einhverfr authored
462 # Keeping this here due to common requirements
463 sub is_allowed_role {
464 my $self = shift @_;
465 my %args = @_;
4c0d0b7 Adding copy=> and merge=>\@list args to DBObject->new
einhverfr authored
466 my @roles = @{$args{allowed_roles}};
467 for my $role (@roles){
dcfdaee Adding role checking function for UI use
einhverfr authored
468 if (scalar(grep /^$role$/, $self->{_roles})){
469 return 1;
470 }
471 }
472 return 1; # TODO change to 0 when the role system is implmented
473 }
474
b058034 Adding ledgersmb.conf.default
einhverfr authored
475 # This should probably be moved to User too...
476 sub date_to_number {
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
477
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
478 #based on SQL-Ledger's Form::datetonum
479 my $self = shift @_;
480 my %args = @_;
481 my $myconfig = $args{user};
482 my $date = $args{date};
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
483
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
484 my ( $yy, $mm, $dd );
485 if ( $date && $date =~ /\D/ ) {
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
486
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
487 if ( $myconfig->{dateformat} =~ /^yy/ ) {
488 ( $yy, $mm, $dd ) = split /\D/, $date;
489 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
490
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
491 if ( $myconfig->{dateformat} =~ /^mm/ ) {
492 ( $mm, $dd, $yy ) = split /\D/, $date;
493 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
494
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
495 if ( $myconfig->{dateformat} =~ /^dd/ ) {
496 ( $dd, $mm, $yy ) = split /\D/, $date;
497 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
498
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
499 $dd *= 1;
500 $mm *= 1;
501 $yy += 2000 if length $yy == 2;
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
502
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
503 $dd = substr( "0$dd", -2 );
504 $mm = substr( "0$mm", -2 );
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
505
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
506 $date = "$yy$mm$dd";
507 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
508
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
509 $date;
510 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
511
c72bdb0 Deleted unnecessary functions from LedgerSMB.pm so we don't become de…
einhverfr authored
512 # Database routines used throughout
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
513
c72bdb0 Deleted unnecessary functions from LedgerSMB.pm so we don't become de…
einhverfr authored
514 sub db_init {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
515 my $self = shift @_;
516 my %args = @_;
517 my $myconfig = $args{user};
b058034 Adding ledgersmb.conf.default
einhverfr authored
518
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
519 my $dbh = DBI->connect(
520 $myconfig->{dbconnect}, $myconfig->{dbuser},
521 $myconfig->{dbpasswd}, { AutoCommit => 0 }
522 ) or $self->dberror;
7555d49 Mostly done rewriting LedgerSMB.pm. There are a few areas that still…
einhverfr authored
523
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
524 $dbh->{pg_server_prepare} = 0;
02ece7f Set database connections to utf8
tetragon authored
525 $dbh->{pg_enable_utf8} = 1;
0e0da8e turning off server-side prepare in new code because it won't buy us a…
einhverfr authored
526
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
527 if ( $myconfig->{dboptions} ) {
528 $dbh->do( $myconfig->{dboptions} );
529 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
530
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
531 my $query = "SELECT t.extends,
c72bdb0 Deleted unnecessary functions from LedgerSMB.pm so we don't become de…
einhverfr authored
532 coalesce (t.table_name, 'custom_' || extends)
533 || ':' || f.field_name as field_def
534 FROM custom_table_catalog t
535 JOIN custom_field_catalog f USING (table_id)";
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
536 my $sth = $self->{dbh}->prepare($query);
537 $sth->execute;
538 my $ref;
539 while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) {
540 push @{ $self->{custom_db_fields}{ $ref->{extends} } },
541 $ref->{field_def};
542 }
c72bdb0 Deleted unnecessary functions from LedgerSMB.pm so we don't become de…
einhverfr authored
543 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
544
545 sub redo_rows {
546
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
547 my $self = shift @_;
548 my %args = @_;
549 my @flds = @{ $args{fields} };
550 my $count = $args{count};
551 my $index = ( $args{index} ) ? $args{index} : 'runningnumber';
552
553 my @rows;
554 my $i; # incriment counter use only
555 for $i ( 1 .. $count ) {
556 my $temphash = { _inc => $i };
557 for my $fld (@flds) {
558 $temphash->{$fld} = $self->{ "$fld" . "_$i" };
559 }
560 push @rows, $temphash;
561 }
562 $i = 1;
563 for my $row ( sort { $a->{index} <=> $b->{index} } @rows ) {
564 for my $fld (@flds) {
565 $self->{ "$fld" . "_$i" } = $row->{$fld};
566 }
567 ++$i;
568 }
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
569 }
570
36dff6b refactoring some methods and getting rid of unnecessary multiple inhe…
einhverfr authored
571 sub merge {
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
572 my ( $self, $src ) = @_;
573 for my $arg ( $self, $src ) {
574 shift;
575 }
576 my %args = @_;
6b9ed8b Fixing Merge so that @keys is truly optional
einhverfr authored
577 my @keys;
578 if (defined $args{keys}){
579 @keys = @{ $args{keys} };
580 }
666fd83 Doing a simple Perltidy commit so that I can evaluate differences bet…
einhverfr authored
581 my $index = $args{index};
582 if ( !scalar @keys ) {
583 @keys = keys %{$src};
584 }
585 for my $arg ( keys %$src ) {
586 my $dst_arg;
587 if ($index) {
588 $dst_arg = $arg . "_$index";
589 }
590 else {
591 $dst_arg = $arg;
592 }
593 $self->{$dst_arg} = $src->{$arg};
594 }
36dff6b refactoring some methods and getting rid of unnecessary multiple inhe…
einhverfr authored
595 }
596
f02f244 First draft of DBObject and LedgerSMB namespace
einhverfr authored
597 1;
Something went wrong with that request. Please try again.