summaryrefslogtreecommitdiff
path: root/LedgerSMB.pm
blob: 37fbe009f8ad10572e41746dafffaaab5d8805f5 (plain)
  1. =head1 NAME
  2. LedgerSMB The Base class for many LedgerSMB objects, including DBObject.
  3. =head1 SYOPSIS
  4. This module creates a basic request handler with utility functions available
  5. in database objects (LedgerSMB::DBObject)
  6. =head1 METHODS
  7. =item new ()
  8. This method creates a new base request instance.
  9. =item date_to_number (user => $LedgerSMB::User, date => $string);
  10. This function takes the date in the format provided and returns a numeric
  11. string in YYMMDD format. This may be moved to User in the future.
  12. =item debug (file => $path);
  13. This dumps the current object to the file if that is defined and otherwise to
  14. standard output.
  15. =item escape (string => $string);
  16. This function returns the current string escaped using %hexhex notation.
  17. =item unescape (string => $string);
  18. This function returns the $string encoded using %hexhex using ordinary notation.
  19. =item format_amount (user => $LedgerSMB::User::hash, amount => $string, precision => $integer, neg_format => (-|DRCR));
  20. The function takes a monetary amount and formats it according to the user
  21. preferences, the negative format (- or DR/CR). Note that it may move to
  22. LedgerSMB::User at some point in the future.
  23. =item parse_amount (user => $LedgerSMB::User::hash, amount => $variable);
  24. If $amount is a Bigfloat, it is returned as is. If it is a string, it is
  25. parsed according to the user preferences stored in the LedgerSMB::User object.
  26. =item format_fields (fields => \@array);
  27. This function converts fields to their appropriate representation in
  28. HTML/SGML/XML or LaTeX.
  29. =item is_blank (name => $string)
  30. This function returns true if $self->{$string} only consists of whitespace
  31. characters or is an empty string.
  32. =item is_run_mode ('(cli|cgi|mod_perl)')
  33. This function returns 1 if the run mode is what is specified. Otherwise
  34. returns 0.
  35. =item num_text_rows (string => $string, cols => $number, max => $number);
  36. This function determines the likely number of rows needed to hold text in a
  37. textbox. It returns either that number or max, which ever is lower.
  38. =item merge ($hashref, keys => @list, index => $number);
  39. This command merges the $hashref into the current object. If keys are
  40. specified, only those keys are used. Otherwise all keys are merged.
  41. If an index is specified, the merged keys are given a form of
  42. "$key" . "_$index", otherwise the key is used on both sides.
  43. =item redirect (msg => $string)
  44. This function redirects to the script and argument set determined by
  45. $self->{callback}, and if this is not set, goes to an info screen and prints
  46. $msg.
  47. =item redo_rows (fields => \@list, count => $integer, [index => $string);
  48. This function is undergoing serious redesign at the moment. If index is
  49. defined, that field is used for ordering the rows. If not, runningnumber is
  50. used. Behavior is not defined when index points to a field containing
  51. non-numbers.
  52. =head1 Copyright (C) 2006, The LedgerSMB core team.
  53. # This work contains copyrighted information from a number of sources all used
  54. # with permission.
  55. #
  56. # This file contains source code included with or based on SQL-Ledger which
  57. # is Copyright Dieter Simader and DWS Systems Inc. 2000-2005 and licensed
  58. # under the GNU General Public License version 2 or, at your option, any later
  59. # version. For a full list including contact information of contributors,
  60. # maintainers, and copyright holders, see the CONTRIBUTORS file.
  61. #
  62. # Original Copyright Notice from SQL-Ledger 2.6.17 (before the fork):
  63. # Copyright (C) 2000
  64. #
  65. # Author: DWS Systems Inc.
  66. # Web: http://www.sql-ledger.org
  67. #
  68. # Contributors: Thomas Bayen <bayen@gmx.de>
  69. # Antti Kaihola <akaihola@siba.fi>
  70. # Moritz Bunkus (tex)
  71. # Jim Rawlings <jim@your-dba.com> (DB2)
  72. #======================================================================
  73. =cut
  74. use CGI;
  75. use Math::BigFloat lib=>'GMP';
  76. use LedgerSMB::Sysconfig;
  77. use Data::Dumper;
  78. use strict;
  79. package LedgerSMB;
  80. sub new {
  81. my $type = shift @_;
  82. my $argstr = shift @_;
  83. my $self = {};
  84. $self->{version} = "1.3.0 Alpha 0 Pre";
  85. $self->{dbversion} = "1.2.0";
  86. bless $self, $type;
  87. my $query = ($argstr) ? new CGI($argstr) : new CGI;
  88. my $params = $query->Vars;
  89. $self->merge($params);
  90. $self->{action} =~ s/\W/_/g;
  91. $self->{action} = lc $self->{action};
  92. if ($self->{path} =~ /lynx/i){
  93. $self->{menubar} = 1;
  94. #menubar will be deprecated, replaced with below
  95. $self->{lynx} = 1;
  96. }
  97. $self->{path} =~ s#\\#/#g;
  98. if (($self->{path}) && ($self->{path} !~ m#^bin/#)
  99. || ($self->{path} =~ m#(\w*/){2,}#)){
  100. $self->error("Access Denied");
  101. }
  102. if (($self->{script} =~ m#(..|\\|/)#)){
  103. $self->error("Access Denied");
  104. }
  105. $self;
  106. }
  107. sub debug {
  108. my $self = shift @_;
  109. my %args = @_;
  110. my $file = $args{file};
  111. my $d = Data::Dumper->new([@_]);
  112. $d->Sortkeys(1);
  113. if ($file) {
  114. open(FH, '>', "$file") or die $!;
  115. print FH $d->Dump();
  116. close(FH);
  117. } else {
  118. print "\n";
  119. print $d->Dump();
  120. }
  121. }
  122. sub escape {
  123. my ($self) = @_;
  124. my %args = @_;
  125. my $str = $args{string};
  126. my $regex = qr/([^a-zA-Z0-9_.-])/;
  127. $str =~ s/$regex/sprintf("%%%02x", ord($1))/ge;
  128. $str;
  129. }
  130. sub is_blank {
  131. my $self = shift @_;
  132. my %args = @_;
  133. my $name = $args{name};
  134. my $rc;
  135. if ($self->{$name} =~ /^\s*$/){
  136. $rc = 1;
  137. } else {
  138. $rc = 0;
  139. }
  140. $rc;
  141. }
  142. sub is_run_mode {
  143. my $self = shift @_;
  144. my $mode = lc shift @_;
  145. my $rc = 0;
  146. if ($mode eq 'cgi' && $ENV{GATEWAY_INTERFACE}){
  147. $rc = 1;
  148. }
  149. elsif ($mode eq 'cli' && ! ($ENV{GATEWAY_INTERFACE} || $ENV{MOD_PERL})){
  150. $rc = 1;
  151. } elsif ($mode eq 'mod_perl' && $ENV{MOD_PERL}){
  152. $rc = 1;
  153. }
  154. $rc;
  155. }
  156. sub num_text_rows {
  157. my $self = shift @_;
  158. my %args = @_;
  159. my $string = $args{string};
  160. my $cols = $args{cols};
  161. my $maxrows = $args{max};
  162. my $rows = 0;
  163. for (split /\n/, $string) {
  164. my $line = $_;
  165. while (length($line) > $cols){
  166. my $fragment = substr($line, 0, $cols + 1);
  167. my $fragment = s/^(.*)\S*$/$1/;
  168. $line = s/$fragment//;
  169. if ($line eq $fragment){ # No word breaks!
  170. $line = "";
  171. }
  172. ++$rows;
  173. }
  174. ++$rows;
  175. }
  176. if (! defined $maxrows){
  177. $maxrows = $rows;
  178. }
  179. return ($rows > $maxrows) ? $maxrows : $rows;
  180. }
  181. sub redirect {
  182. my $self = shift @_;
  183. my %args = @_;
  184. my $msg = $args{msg};
  185. if ($self->{callback} || !$msg) {
  186. main::redirect();
  187. } else {
  188. $self->info($msg);
  189. }
  190. }
  191. sub format_fields {
  192. # Based on SQL-Ledger's Form::format_string
  193. # We should look at moving this into LedgerSMB::Template.
  194. # And cleaning it up...... Chris
  195. my $self = shift @_;
  196. my %args = @_;
  197. my @fields = @{$args{fields}};
  198. my $format = $self->{format};
  199. if ($self->{format} =~ /(postscript|pdf)/) {
  200. $format = 'tex';
  201. }
  202. my %replace = (
  203. 'order' => {
  204. html => [ '<', '>', '\n', '\r' ],
  205. txt => [ '\n', '\r' ],
  206. tex => [ quotemeta('\\'), '&', '\n','\r',
  207. '\$', '%', '_', '#',
  208. quotemeta('^'), '{', '}', '<', '>', '£'
  209. ] },
  210. html => { '<' => '&lt;', '>' => '&gt;','\n' => '<br />',
  211. '\r' => '<br />' },
  212. txt => { '\n' => "\n", '\r' => "\r" },
  213. tex => {'&' => '\&', '$' => '\$', '%' => '\%', '_' => '\_',
  214. '#' => '\#', quotemeta('^') => '\^\\', '{' => '\{',
  215. '}' => '\}', '<' => '$<$', '>' => '$>$',
  216. '\n' => '\newline ', '\r' => '\newline ',
  217. '£' => '\pounds ', quotemeta('\\') => '/'}
  218. );
  219. my $key;
  220. foreach $key (@{ $replace{order}{$format} }) {
  221. for (@fields) { $self->{$_} =~ s/$key/$replace{$format}{$key}/g }
  222. }
  223. }
  224. # TODO: Either we should have an amount class with formats and such attached
  225. # Or maybe we should move this into the user class...
  226. sub format_amount {
  227. # Based on SQL-Ledger's Form::format_amount
  228. my $self = shift @_;
  229. my %args = @_;
  230. my $myconfig = $args{user};
  231. my $amount = $args{amount};
  232. my $places = $args{precision};
  233. my $dash = $args{neg_format};
  234. my $negative ;
  235. if ($amount){
  236. $amount = $self->parse_amount($myconfig, $amount);
  237. $negative = ($amount < 0);
  238. $amount =~ s/-//;
  239. }
  240. if ($places =~ /\d+/) {
  241. #$places = 4 if $places == 2;
  242. $amount = $self->round_amount($amount, $places);
  243. }
  244. # is the amount negative
  245. # Parse $myconfig->{numberformat}
  246. my ($ts, $ds) = ($1, $2);
  247. if ($amount) {
  248. if ($myconfig->{numberformat}) {
  249. my ($whole, $dec) = split /\./, "$amount";
  250. $amount = join '', reverse split //, $whole;
  251. if ($places) {
  252. $dec .= "0" x $places;
  253. $dec = substr($dec, 0, $places);
  254. }
  255. if ($myconfig->{numberformat} eq '1,000.00') {
  256. $amount =~ s/\d{3,}?/$&,/g;
  257. $amount =~ s/,$//;
  258. $amount = join '', reverse split //, $amount;
  259. $amount .= "\.$dec" if ($dec ne "");
  260. }
  261. if ($myconfig->{numberformat} eq '1 000.00') {
  262. $amount =~ s/\d{3,}?/$& /g;
  263. $amount =~ s/\s$//;
  264. $amount = join '', reverse split //, $amount;
  265. $amount .= "\.$dec" if ($dec ne "");
  266. }
  267. if ($myconfig->{numberformat} eq "1'000.00") {
  268. $amount =~ s/\d{3,}?/$&'/g;
  269. $amount =~ s/'$//;
  270. $amount = join '', reverse split //, $amount;
  271. $amount .= "\.$dec" if ($dec ne "");
  272. }
  273. if ($myconfig->{numberformat} eq '1.000,00') {
  274. $amount =~ s/\d{3,}?/$&./g;
  275. $amount =~ s/\.$//;
  276. $amount = join '', reverse split //, $amount;
  277. $amount .= ",$dec" if ($dec ne "");
  278. }
  279. if ($myconfig->{numberformat} eq '1000,00') {
  280. $amount = "$whole";
  281. $amount .= ",$dec" if ($dec ne "");
  282. }
  283. if ($myconfig->{numberformat} eq '1000.00') {
  284. $amount = "$whole";
  285. $amount .= ".$dec" if ($dec ne "");
  286. }
  287. if ($dash =~ /-/) {
  288. $amount = ($negative) ? "($amount)" : "$amount";
  289. } elsif ($dash =~ /DRCR/) {
  290. $amount = ($negative) ? "$amount DR" : "$amount CR";
  291. } else {
  292. $amount = ($negative) ? "-$amount" : "$amount";
  293. }
  294. }
  295. } else {
  296. if ($dash eq "0" && $places) {
  297. if ($myconfig->{numberformat} eq '1.000,00') {
  298. $amount = "0".","."0" x $places;
  299. } else {
  300. $amount = "0"."."."0" x $places;
  301. }
  302. } else {
  303. $amount = ($dash ne "") ? "$dash" : "";
  304. }
  305. }
  306. $amount;
  307. }
  308. # This should probably go to the User object too.
  309. sub parse_amount {
  310. my $self = shift @_;
  311. my %args = @_;
  312. my $myconfig = $args{user};
  313. my $amount = $args{amount};
  314. if ($amount eq '' or $amount == undef){
  315. return 0;
  316. }
  317. if (UNIVERSAL::isa($amount, 'Math::BigFloat')){ # Amount may not be an object
  318. return $amount;
  319. }
  320. my $numberformat = $myconfig->{numberformat};
  321. if (($numberformat eq '1.000,00') ||
  322. ($numberformat eq '1000,00')) {
  323. $amount =~ s/\.//g;
  324. $amount =~ s/,/./;
  325. }
  326. if ($numberformat eq '1 000.00'){
  327. $amount =~ s/\s//g;
  328. }
  329. if ($numberformat eq "1'000.00") {
  330. $amount =~ s/'//g;
  331. }
  332. $amount =~ s/,//g;
  333. if ($amount =~ s/\((\d*\.?\d*)\)/$1/){
  334. $amount = $1 * -1;
  335. }
  336. if ($amount =~ s/(\d*\.?\d*)\s?DR/$1/){
  337. $amount = $1 * -1;
  338. }
  339. $amount =~ s/\s?CR//;
  340. $amount = new Math::BigFloat($amount);
  341. return ($amount * 1);
  342. }
  343. sub round_amount {
  344. my ($self, $amount, $places) = @_;
  345. # These rounding rules follow from the previous implementation.
  346. # They should be changed to allow different rules for different accounts.
  347. Math::BigFloat->round_mode('+inf') if $amount >= 0;
  348. Math::BigFloat->round_mode('-inf') if $amount < 0;
  349. $amount = Math::BigFloat->new($amount)->ffround(-$places) if $places >= 0;
  350. $amount = Math::BigFloat->new($amount)->ffround(-($places-1)) if $places < 0;
  351. return $amount;
  352. }
  353. sub call_procedure {
  354. my $self = shift @_;
  355. my %args = @_;
  356. my $procname = $args{procname};
  357. my @args = @{$args{args}};
  358. my $argstr = "";
  359. my @results;
  360. for (1 .. scalar @args){
  361. $argstr .= "?, ";
  362. }
  363. $argstr =~ s/\, $//;
  364. my $query = "SELECT * FROM $procname()";
  365. $query =~ s/\(\)/($argstr)/;
  366. my $sth = $self->{dbh}->prepare($query);
  367. $sth->execute(@args);
  368. while (my $ref = $sth->fetchrow_hashref('NAME_lc')){
  369. push @results, $ref;
  370. }
  371. @results;
  372. }
  373. # This should probably be moved to User too...
  374. sub date_to_number {
  375. #based on SQL-Ledger's Form::datetonum
  376. my $self = shift @_;
  377. my %args = @_;
  378. my $myconfig = $args{user};
  379. my $date = $args{date};
  380. my ($yy, $mm, $dd);
  381. if ($date && $date =~ /\D/) {
  382. if ($myconfig->{dateformat} =~ /^yy/) {
  383. ($yy, $mm, $dd) = split /\D/, $date;
  384. }
  385. if ($myconfig->{dateformat} =~ /^mm/) {
  386. ($mm, $dd, $yy) = split /\D/, $date;
  387. }
  388. if ($myconfig->{dateformat} =~ /^dd/) {
  389. ($dd, $mm, $yy) = split /\D/, $date;
  390. }
  391. $dd *= 1;
  392. $mm *= 1;
  393. $yy += 2000 if length $yy == 2;
  394. $dd = substr("0$dd", -2);
  395. $mm = substr("0$mm", -2);
  396. $date = "$yy$mm$dd";
  397. }
  398. $date;
  399. }
  400. # Database routines used throughout
  401. sub db_init {
  402. my $self = shift @_;
  403. my %args = @_;
  404. my $myconfig = $args{user};
  405. my $dbh = DBI->connect($myconfig->{dbconnect}, $myconfig->{dbuser},
  406. $myconfig->{dbpasswd}, {AutoCommit => 0}) or $self->dberror;
  407. if ($myconfig->{dboptions}) {
  408. $dbh->do($myconfig->{dboptions});
  409. }
  410. my $query =
  411. "SELECT t.extends,
  412. coalesce (t.table_name, 'custom_' || extends)
  413. || ':' || f.field_name as field_def
  414. FROM custom_table_catalog t
  415. JOIN custom_field_catalog f USING (table_id)";
  416. my $sth = $self->{dbh}->prepare($query);
  417. $sth->execute;
  418. my $ref;
  419. while ($ref = $sth->fetchrow_hashref('NAME_lc')){
  420. push @{$self->{custom_db_fields}{$ref->{extends}}},
  421. $ref->{field_def};
  422. }
  423. }
  424. sub redo_rows {
  425. my $self = shift @_;
  426. my %args = @_;
  427. my @flds = @{$args{fields}};
  428. my $count = $args{count};
  429. my $index = ($args{index}) ? $args{index} : 'runningnumber';
  430. my @rows;
  431. my $i; # incriment counter use only
  432. for $i (1 .. $count){
  433. my $temphash = {_inc => $i};
  434. for my $fld (@flds){
  435. $temphash->{$fld} = $self->{"$fld"."_$i"}
  436. }
  437. push @rows, $temphash;
  438. }
  439. $i = 1;
  440. for my $row (sort {$a->{index} <=> $b->{index}} @rows){
  441. for my $fld (@flds){
  442. $self->{"$fld"."_$i"} = $row->{$fld};
  443. }
  444. ++$i;
  445. }
  446. }
  447. sub merge {
  448. my ($self, $src) = @_;
  449. for my $arg ($self, $src){
  450. shift;
  451. }
  452. my %args = @_;
  453. my @keys = @{$args{keys}};
  454. my $index = $args{index};
  455. if (! scalar @keys){
  456. @keys = keys %{$src};
  457. }
  458. for my $arg (keys %$src){
  459. my $dst_arg;
  460. if ($index){
  461. $dst_arg = $arg . "_$index";
  462. } else {
  463. $dst_arg = $arg;
  464. }
  465. $self->{$dst_arg} = $src->{$arg};
  466. }
  467. }
  468. 1;