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