summaryrefslogtreecommitdiff
path: root/LedgerSMB.pm
blob: 9a38149db6e089cee1d2671912914b699fefb5be (plain)
  1. =head1 NAME
  2. LedgerSMB The Base class for many LedgerSMB objects, including DBObject.
  3. =head1 SYNOPSIS
  4. This module creates a basic request handler with utility functions available
  5. in database objects (LedgerSMB::DBObject)
  6. =head1 METHODS
  7. =over
  8. =item new ()
  9. This method creates a new base request instance. It also validates the
  10. session/user credentials, as appropriate for the run mode. Finally, it sets up
  11. the database connections for the user.
  12. =item date_to_number (user => $LedgerSMB::User, date => $string);
  13. This function takes the date in the format provided and returns a numeric
  14. string in YYMMDD format. This may be moved to User in the future.
  15. =item debug (file => $path);
  16. This dumps the current object to the file if that is defined and otherwise to
  17. standard output.
  18. =item escape (string => $string);
  19. This function returns the current string escaped using %hexhex notation.
  20. =item unescape (string => $string);
  21. This function returns the $string encoded using %hexhex using ordinary notation.
  22. =item format_amount (user => $LedgerSMB::User::hash, amount => $string, precision => $integer, neg_format => (-|DRCR));
  23. The function takes a monetary amount and formats it according to the user
  24. preferences, the negative format (- or DR/CR). Note that it may move to
  25. LedgerSMB::User at some point in the future.
  26. =item parse_amount (user => $LedgerSMB::User::hash, amount => $variable);
  27. If $amount is a Bigfloat, it is returned as is. If it is a string, it is
  28. parsed according to the user preferences stored in the LedgerSMB::User object.
  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 is_allowed_role(allowed_roles => @role_names)
  36. This function returns 1 if the user's roles include any of the roles in
  37. @role_names. Currently it returns 1 when this is not found as well but when
  38. role permissions are introduced, this will change to 0.
  39. =item num_text_rows (string => $string, cols => $number, max => $number);
  40. This function determines the likely number of rows needed to hold text in a
  41. textbox. It returns either that number or max, which ever is lower.
  42. =item merge ($hashref, keys => @list, index => $number);
  43. This command merges the $hashref into the current object. If keys are
  44. specified, only those keys are used. Otherwise all keys are merged.
  45. If an index is specified, the merged keys are given a form of
  46. "$key" . "_$index", otherwise the key is used on both sides.
  47. =item redirect (msg => $string)
  48. This function redirects to the script and argument set determined by
  49. $self->{callback}, and if this is not set, goes to an info screen and prints
  50. $msg.
  51. =item redo_rows (fields => \@list, count => $integer, [index => $string);
  52. This function is undergoing serious redesign at the moment. If index is
  53. defined, that field is used for ordering the rows. If not, runningnumber is
  54. used. Behavior is not defined when index points to a field containing
  55. non-numbers.
  56. =item set (@attrs)
  57. Copies the given key=>vars to $self. Allows for finer control of
  58. merging hashes into self.
  59. =item remove_cgi_globals()
  60. Removes all elements starting with a . because these elements conflict with the
  61. ability to hide the entire structure for things like CSV lookups.
  62. =back
  63. =head1 Copyright (C) 2006, The LedgerSMB core team.
  64. # This work contains copyrighted information from a number of sources
  65. # all used with permission.
  66. #
  67. # This file contains source code included with or based on SQL-Ledger
  68. # which is Copyright Dieter Simader and DWS Systems Inc. 2000-2005
  69. # and licensed under the GNU General Public License version 2 or, at
  70. # your option, any later version. For a full list including contact
  71. # information of contributors, maintainers, and copyright holders,
  72. # see the CONTRIBUTORS file.
  73. #
  74. # Original Copyright Notice from SQL-Ledger 2.6.17 (before the fork):
  75. # Copyright (C) 2000
  76. #
  77. # Author: DWS Systems Inc.
  78. # Web: http://www.sql-ledger.org
  79. #
  80. # Contributors: Thomas Bayen <bayen@gmx.de>
  81. # Antti Kaihola <akaihola@siba.fi>
  82. # Moritz Bunkus (tex)
  83. # Jim Rawlings <jim@your-dba.com> (DB2)
  84. #====================================================================
  85. =cut
  86. use CGI::Simple;
  87. use Math::BigFloat;
  88. use LedgerSMB::Sysconfig;
  89. use Data::Dumper;
  90. use LedgerSMB::Auth;
  91. use LedgerSMB::Template;
  92. use LedgerSMB::Locale;
  93. use LedgerSMB::User;
  94. use strict;
  95. $CGI::Simple::POST_MAX = -1;
  96. package LedgerSMB;
  97. our $VERSION = '1.2.99';
  98. sub new {
  99. my $type = shift @_;
  100. my $argstr = shift @_;
  101. my %cookie;
  102. my $self = {};
  103. $self->{version} = $VERSION;
  104. $self->{dbversion} = "1.2.0";
  105. bless $self, $type;
  106. my $query = ($argstr) ? new CGI::Simple($argstr) : new CGI::Simple;
  107. my $params = $query->Vars;
  108. $self->{VERSION} = $VERSION;
  109. $self->merge($params);
  110. $self->{have_latex} = $LedgerSMB::Sysconfig::latex;
  111. # Adding this so that empty values are stored in the db as NULL's. If
  112. # stored procedures want to handle them differently, they must opt to do so.
  113. # -- CT
  114. for (keys %$self){
  115. if ($self->{$_} eq ''){
  116. $self->{$_} = undef;
  117. }
  118. }
  119. if ($self->is_run_mode('cgi', 'mod_perl')) {
  120. $ENV{HTTP_COOKIE} =~ s/;\s*/;/g;
  121. my @cookies = split /;/, $ENV{HTTP_COOKIE};
  122. foreach (@cookies) {
  123. my ( $name, $value ) = split /=/, $_, 2;
  124. $cookie{$name} = $value;
  125. }
  126. }
  127. $self->{action} =~ s/\W/_/g;
  128. $self->{action} = lc $self->{action};
  129. if ( $self->{path} eq "bin/lynx" ) {
  130. $self->{menubar} = 1;
  131. # Applying the path is deprecated. Use menubar instead. CT.
  132. $self->{lynx} = 1;
  133. $self->{path} = "bin/lynx";
  134. }
  135. else {
  136. $self->{path} = "bin/mozilla";
  137. }
  138. if ( ( $self->{script} =~ m#(\.\.|\\|/)# ) ) {
  139. $self->error("Access Denied");
  140. }
  141. if (!$self->{script}) {
  142. $self->{script} = 'login.pl';
  143. }
  144. if (($self->{script} eq 'login.pl') &&
  145. ($self->{action} eq 'authenticate' || !$self->{action})){
  146. return $self;
  147. }
  148. if (!$self->{company} && $self->is_run_mode('cgi', 'mod_perl')){
  149. my $ccookie = $cookie{LedgerSMB};
  150. $ccookie =~ s/.*:([^:]*)$/$1/;
  151. $self->{company} = $ccookie;
  152. }
  153. $self->_db_init;
  154. if ($self->is_run_mode('cgi', 'mod_perl')) {
  155. #check for valid session unless this is an inital authentication
  156. #request -- CT
  157. if (!LedgerSMB::Auth::session_check( $cookie{"LedgerSMB"}, $self) ) {
  158. print STDERR "Session did not check";
  159. $self->_get_password("Session Expired");
  160. exit;
  161. }
  162. $self->{_user} = LedgerSMB::User->fetch_config($self);
  163. }
  164. my %date_setting = (
  165. 'mm/dd/yy' => "SQL, US",
  166. 'mm-dd-yy' => "POSTGRES, US",
  167. 'dd/mm/yy' => "SQL, EUROPEAN",
  168. 'dd-mm-yy' => "POSTGRES, EUROPEAN",
  169. 'dd.mm.yy' => "GERMAN",
  170. );
  171. $self->{dbh}->do("set DateStyle to '"
  172. .$date_setting{$self->{_user}->{dateformat}}."'");
  173. #my $locale = LedgerSMB::Locale->get_handle($self->{_user}->{countrycode})
  174. $self->{_locale} = LedgerSMB::Locale->get_handle('en') # temporary
  175. or $self->error(__FILE__.':'.__LINE__.": Locale not loaded: $!\n");
  176. $self->{stylesheet} = $self->{_user}->{stylesheet};
  177. return $self;
  178. }
  179. #This function needs to be moved into the session handler.
  180. sub _get_password {
  181. my ($self) = shift @_;
  182. $self->{sessionexpired} = shift @_;
  183. LedgerSMB::Auth::credential_prompt();
  184. exit;
  185. }
  186. sub debug {
  187. my $self = shift @_;
  188. my $args = shift @_;
  189. my $file;
  190. if (scalar keys %$args){
  191. $file = $args->{'file'};
  192. }
  193. my $d = Data::Dumper->new( [$self] );
  194. $d->Sortkeys(1);
  195. if ($file) {
  196. open( FH, '>', "$file" ) or die $!;
  197. print FH $d->Dump();
  198. close(FH);
  199. }
  200. else {
  201. print "\n";
  202. print $d->Dump();
  203. }
  204. }
  205. sub escape {
  206. my $self = shift;
  207. my %args = @_;
  208. my $str = $args{string};
  209. my $regex = qr/([^a-zA-Z0-9_.-])/;
  210. $str =~ s/$regex/sprintf("%%%02x", ord($1))/ge;
  211. return $str;
  212. }
  213. sub is_blank {
  214. my $self = shift @_;
  215. my %args = @_;
  216. my $name = $args{name};
  217. if (not defined $name){
  218. # TODO: Raise error
  219. }
  220. my $rc;
  221. if ( $self->{$name} =~ /^\s*$/ ) {
  222. $rc = 1;
  223. }
  224. else {
  225. $rc = 0;
  226. }
  227. $rc;
  228. }
  229. sub is_run_mode {
  230. my $self = shift @_;
  231. my $mode = lc shift @_;
  232. my $rc = 0;
  233. if ( $mode eq 'cgi' && $ENV{GATEWAY_INTERFACE} ) {
  234. $rc = 1;
  235. }
  236. elsif ( $mode eq 'cli' && !( $ENV{GATEWAY_INTERFACE} || $ENV{MOD_PERL} ) ) {
  237. $rc = 1;
  238. }
  239. elsif ( $mode eq 'mod_perl' && $ENV{MOD_PERL} ) {
  240. $rc = 1;
  241. }
  242. $rc;
  243. }
  244. sub num_text_rows {
  245. my $self = shift @_;
  246. my %args = @_;
  247. my $string = $args{string};
  248. my $cols = $args{cols};
  249. my $maxrows = $args{max};
  250. my $rows = 0;
  251. for ( split /\n/, $string ) {
  252. my $line = $_;
  253. while ( length($line) > $cols ) {
  254. my $fragment = substr( $line, 0, $cols + 1 );
  255. $fragment =~ s/^(.*)\W.*$/$1/;
  256. $line =~ s/$fragment//;
  257. if ( $line eq $fragment ) { # No word breaks!
  258. $line = "";
  259. }
  260. ++$rows;
  261. }
  262. ++$rows;
  263. }
  264. if ( !defined $maxrows ) {
  265. $maxrows = $rows;
  266. }
  267. return ( $rows > $maxrows ) ? $maxrows : $rows;
  268. }
  269. sub redirect {
  270. my $self = shift @_;
  271. my %args = @_;
  272. my $msg = $args{msg};
  273. if ( $self->{callback} || !$msg ) {
  274. main::redirect();
  275. exit;
  276. }
  277. else {
  278. $self->info($msg);
  279. }
  280. }
  281. # TODO: Either we should have an amount class with formats and such attached
  282. # Or maybe we should move this into the user class...
  283. sub format_amount {
  284. # Based on SQL-Ledger's Form::format_amount
  285. my $self = shift @_;
  286. my %args = @_;
  287. my $myconfig = $args{user} || $self->{_user};
  288. my $amount = $args{amount};
  289. my $places = $args{precision};
  290. my $dash = $args{neg_format};
  291. my $negative;
  292. if ($amount) {
  293. $amount = $self->parse_amount( 'user' => $myconfig, 'amount' => $amount );
  294. $negative = ( $amount < 0 );
  295. $amount =~ s/-//;
  296. }
  297. if ( $places =~ /\d+/ ) {
  298. #$places = 4 if $places == 2;
  299. $amount = $self->round_amount( $amount, $places );
  300. }
  301. # is the amount negative
  302. # Parse $myconfig->{numberformat}
  303. my ( $ts, $ds ) = ( $1, $2 );
  304. if ($amount) {
  305. if ( $myconfig->{numberformat} ) {
  306. my ( $whole, $dec ) = split /\./, "$amount";
  307. $amount = join '', reverse split //, $whole;
  308. if ($places) {
  309. $dec .= "0" x $places;
  310. $dec = substr( $dec, 0, $places );
  311. }
  312. if ( $myconfig->{numberformat} eq '1,000.00' ) {
  313. $amount =~ s/\d{3,}?/$&,/g;
  314. $amount =~ s/,$//;
  315. $amount = join '', reverse split //, $amount;
  316. $amount .= "\.$dec" if ( $dec ne "" );
  317. }
  318. elsif ( $myconfig->{numberformat} eq '1 000.00' ) {
  319. $amount =~ s/\d{3,}?/$& /g;
  320. $amount =~ s/\s$//;
  321. $amount = join '', reverse split //, $amount;
  322. $amount .= "\.$dec" if ( $dec ne "" );
  323. }
  324. elsif ( $myconfig->{numberformat} eq "1'000.00" ) {
  325. $amount =~ s/\d{3,}?/$&'/g;
  326. $amount =~ s/'$//;
  327. $amount = join '', reverse split //, $amount;
  328. $amount .= "\.$dec" if ( $dec ne "" );
  329. }
  330. elsif ( $myconfig->{numberformat} eq '1.000,00' ) {
  331. $amount =~ s/\d{3,}?/$&./g;
  332. $amount =~ s/\.$//;
  333. $amount = join '', reverse split //, $amount;
  334. $amount .= ",$dec" if ( $dec ne "" );
  335. }
  336. elsif ( $myconfig->{numberformat} eq '1000,00' ) {
  337. $amount = "$whole";
  338. $amount .= ",$dec" if ( $dec ne "" );
  339. }
  340. elsif ( $myconfig->{numberformat} eq '1000.00' ) {
  341. $amount = "$whole";
  342. $amount .= ".$dec" if ( $dec ne "" );
  343. }
  344. if ( $dash =~ /-/ ) {
  345. $amount = ($negative) ? "($amount)" : "$amount";
  346. }
  347. elsif ( $dash =~ /DRCR/ ) {
  348. $amount = ($negative) ? "$amount DR" : "$amount CR";
  349. }
  350. else {
  351. $amount = ($negative) ? "-$amount" : "$amount";
  352. }
  353. }
  354. }
  355. else {
  356. if ( $dash eq "0" && $places ) {
  357. if ( $myconfig->{numberformat} =~ /0,00$/ ) {
  358. $amount = "0" . "," . "0" x $places;
  359. }
  360. else {
  361. $amount = "0" . "." . "0" x $places;
  362. }
  363. }
  364. else {
  365. $amount = ( $dash ne "" ) ? "$dash" : "";
  366. }
  367. }
  368. $amount;
  369. }
  370. # This should probably go to the User object too.
  371. sub parse_amount {
  372. my $self = shift @_;
  373. my %args = @_;
  374. my $myconfig = $args{user} || $self->{_user};
  375. my $amount = $args{amount};
  376. if ( $amount eq '' or ! defined $amount) {
  377. return 0;
  378. }
  379. if ( UNIVERSAL::isa( $amount, 'Math::BigFloat' ) )
  380. { # Amount may not be an object
  381. return $amount;
  382. }
  383. my $numberformat = $myconfig->{numberformat};
  384. if ( ( $numberformat eq '1.000,00' )
  385. || ( $numberformat eq '1000,00' ) )
  386. {
  387. $amount =~ s/\.//g;
  388. $amount =~ s/,/./;
  389. }
  390. elsif ( $numberformat eq '1 000.00' ) {
  391. $amount =~ s/\s//g;
  392. }
  393. elsif ( $numberformat eq "1'000.00" ) {
  394. $amount =~ s/'//g;
  395. }
  396. $amount =~ s/,//g;
  397. if ( $amount =~ s/\((\d*\.?\d*)\)/$1/ ) {
  398. $amount = $1 * -1;
  399. }
  400. elsif ( $amount =~ s/(\d*\.?\d*)\s?DR/$1/ ) {
  401. $amount = $1 * -1;
  402. }
  403. $amount =~ s/\s?CR//;
  404. $amount = new Math::BigFloat($amount);
  405. if ($amount->is_nan){
  406. $self->error("Invalid number detected during parsing");
  407. }
  408. return ( $amount * 1 );
  409. }
  410. sub round_amount {
  411. my ( $self, $amount, $places ) = @_;
  412. # These rounding rules follow from the previous implementation.
  413. # They should be changed to allow different rules for different accounts.
  414. if ($amount >= 0) {
  415. Math::BigFloat->round_mode('+inf');
  416. }
  417. else {
  418. Math::BigFloat->round_mode('-inf');
  419. }
  420. if ($places >= 0) {
  421. $amount = Math::BigFloat->new($amount)->ffround( -$places );
  422. }
  423. else {
  424. $amount = Math::BigFloat->new($amount)->ffround( -( $places - 1 ) );
  425. }
  426. $amount->precision(undef);
  427. return $amount;
  428. }
  429. sub call_procedure {
  430. my $self = shift @_;
  431. my %args = @_;
  432. my $procname = $args{procname};
  433. my @call_args;
  434. @call_args = @{ $args{args} } if defined $args{args};
  435. my $order_by = $args{order_by};
  436. my $argstr = "";
  437. my @results;
  438. $procname = $self->{dbh}->quote_identifier($procname);
  439. for ( 1 .. scalar @call_args ) {
  440. $argstr .= "?, ";
  441. }
  442. $argstr =~ s/\, $//;
  443. my $query = "SELECT * FROM $procname()";
  444. if ($order_by){
  445. $query .= " ORDER BY $order_by";
  446. }
  447. $query =~ s/\(\)/($argstr)/;
  448. my $sth = $self->{dbh}->prepare($query);
  449. if (scalar @call_args){
  450. $sth->execute(@call_args) || $self->error($self->{dbh}->errstr);
  451. } else {
  452. $sth->execute() || $self->error($self->{dbh}->errstr);
  453. }
  454. my @types = @{$sth->{TYPE}};
  455. my @names = @{$sth->{NAME_lc}};
  456. while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  457. for (0 .. $#names){
  458. # numeric float4/real
  459. if ($types[$_] == 3 or $types[$_] == 2) {
  460. $ref->{$names[$_]} = Math::BigFloat->new($ref->{$names[$_]});
  461. }
  462. }
  463. push @results, $ref;
  464. }
  465. @results;
  466. }
  467. # Keeping this here due to common requirements
  468. sub is_allowed_role {
  469. my $self = shift @_;
  470. my %args = @_;
  471. my @roles = @{$args{allowed_roles}};
  472. for my $role (@roles){
  473. if (scalar(grep /^$role$/, $self->{_roles})){
  474. return 1;
  475. }
  476. }
  477. return 1; # TODO change to 0 when the role system is implmented
  478. }
  479. # This should probably be moved to User too...
  480. sub date_to_number {
  481. #based on SQL-Ledger's Form::datetonum
  482. my $self = shift @_;
  483. my %args = @_;
  484. my $myconfig = $args{user};
  485. my $date = $args{date};
  486. my ( $yy, $mm, $dd );
  487. if ( $date && $date =~ /\D/ ) {
  488. if ( $date =~ /^\d{4}-\d\d-\d\d$/ ) {
  489. ( $yy, $mm, $dd ) = split /\D/, $date;
  490. } elsif ( $myconfig->{dateformat} =~ /^yy/ ) {
  491. ( $yy, $mm, $dd ) = split /\D/, $date;
  492. } elsif ( $myconfig->{dateformat} =~ /^mm/ ) {
  493. ( $mm, $dd, $yy ) = split /\D/, $date;
  494. } elsif ( $myconfig->{dateformat} =~ /^dd/ ) {
  495. ( $dd, $mm, $yy ) = split /\D/, $date;
  496. }
  497. $dd *= 1;
  498. $mm *= 1;
  499. $yy += 2000 if length $yy == 2;
  500. $dd = substr( "0$dd", -2 );
  501. $mm = substr( "0$mm", -2 );
  502. $date = "$yy$mm$dd";
  503. }
  504. $date;
  505. }
  506. # To be replaced with a generic interface to an Error class
  507. sub error {
  508. my ( $self, $msg ) = @_;
  509. if ( $ENV{GATEWAY_INTERFACE} ) {
  510. $self->{msg} = $msg;
  511. $self->{format} = "html";
  512. delete $self->{pre};
  513. print qq|Content-Type: text/html; charset=utf-8\n\n|;
  514. print "<head></head>";
  515. print
  516. qq|<body><h2 class="error">Error!</h2> <p><b>$self->{msg}</b></body>|;
  517. exit;
  518. }
  519. else {
  520. if ( $ENV{error_function} ) {
  521. &{ $ENV{error_function} }($msg);
  522. }
  523. die "Error: $msg\n";
  524. }
  525. }
  526. # Database routines used throughout
  527. sub _db_init {
  528. my $self = shift @_;
  529. my %args = @_;
  530. my $creds = LedgerSMB::Auth::get_credentials();
  531. $self->{login} = $creds->{login};
  532. if (!$self->{company}){
  533. $self->{company} = $LedgerSMB::Sysconfig::default_db;
  534. }
  535. my $dbname = $self->{company};
  536. # Note that we have to request the login/password again if the db
  537. # connection fails since this probably means bad credentials are entered.
  538. # Just in case, however, I think it is a good idea to include the DBI
  539. # error string. CT
  540. $self->{dbh} = DBI->connect(
  541. "dbi:Pg:dbname=$dbname", "$creds->{login}", "$creds->{password}", { AutoCommit => 0 }
  542. );
  543. my $dbh = $self->{dbh};
  544. if (($self->{script} eq 'login.pl') && ($self->{action} eq
  545. 'authenticate')){
  546. return;
  547. }
  548. elsif (!$dbh){
  549. $self->_get_password;
  550. }
  551. $dbh->{pg_server_prepare} = 0;
  552. $dbh->{pg_enable_utf8} = 1;
  553. # This is the general version check
  554. my $sth = $dbh->prepare("
  555. SELECT value FROM defaults
  556. WHERE setting_key = 'version'");
  557. $sth->execute;
  558. my ($dbversion) = $sth->fetchrow_array;
  559. if ($dbversion ne $self->{dbversion}){
  560. $self->error("Database is not the expected version. Was $dbversion, expected $self->{dbversion}");
  561. }
  562. my $query = "SELECT t.extends,
  563. coalesce (t.table_name, 'custom_' || extends)
  564. || ':' || f.field_name as field_def
  565. FROM custom_table_catalog t
  566. JOIN custom_field_catalog f USING (table_id)";
  567. my $sth = $self->{dbh}->prepare($query);
  568. $sth->execute;
  569. my $ref;
  570. while ( $ref = $sth->fetchrow_hashref('NAME_lc') ) {
  571. push @{ $self->{custom_db_fields}{ $ref->{extends} } },
  572. $ref->{field_def};
  573. }
  574. }
  575. # Deprecated, only here for old code
  576. sub dberror{
  577. my $self = shift @_;
  578. $self->error(@_);
  579. }
  580. sub redo_rows {
  581. my $self = shift @_;
  582. my %args = @_;
  583. my @flds = @{ $args{fields} };
  584. my $count = $args{count};
  585. my $index = ( $args{index} ) ? $args{index} : 'runningnumber';
  586. my @rows;
  587. my $i; # incriment counter use only
  588. for $i ( 1 .. $count ) {
  589. my $temphash = { _inc => $i };
  590. for my $fld (@flds) {
  591. $temphash->{$fld} = $self->{ "$fld" . "_$i" };
  592. }
  593. push @rows, $temphash;
  594. }
  595. $i = 1;
  596. for my $row ( sort { $a->{index} <=> $b->{index} } @rows ) {
  597. for my $fld (@flds) {
  598. $self->{ "$fld" . "_$i" } = $row->{$fld};
  599. }
  600. ++$i;
  601. }
  602. }
  603. sub merge {
  604. my ( $self, $src ) = @_;
  605. for my $arg ( $self, $src ) {
  606. shift;
  607. }
  608. my %args = @_;
  609. my @keys;
  610. if (defined $args{keys}){
  611. @keys = @{ $args{keys} };
  612. }
  613. my $index = $args{index};
  614. if ( !scalar @keys ) {
  615. @keys = keys %{$src};
  616. }
  617. for my $arg ( @keys ) {
  618. my $dst_arg;
  619. if ($index) {
  620. $dst_arg = $arg . "_$index";
  621. }
  622. else {
  623. $dst_arg = $arg;
  624. }
  625. $self->{$dst_arg} = $src->{$arg};
  626. }
  627. }
  628. sub type {
  629. my $self = shift @_;
  630. if (!$ENV{REQUEST_METHOD} or
  631. ( !grep {$ENV{REQUEST_METHOD} eq $_} ("HEAD", "GET", "POST") ) ) {
  632. $self->error("Request method unset or set to unknown value");
  633. }
  634. return $ENV{REQUEST_METHOD};
  635. }
  636. sub DESTROY {}
  637. sub set {
  638. my $self = shift @_;
  639. my %args = @_;
  640. for my $arg (keys(%args)) {
  641. $self->{$arg} = $args{$arg};
  642. }
  643. return 1;
  644. }
  645. sub remove_cgi_globals {
  646. my ($self) = @_;
  647. for my $key (keys %$self){
  648. if ($key =~ /^\./){
  649. delete $self->{key}
  650. }
  651. }
  652. }
  653. sub take_top_level {
  654. my ($self) = @_;
  655. my $return_hash = {};
  656. for my $key (keys %$self){
  657. if (!ref($self->{$key}) && $key !~ /^\./){
  658. $return_hash->{$key} = $self->{$key}
  659. }
  660. }
  661. return $return_hash;
  662. }
  663. 1;