1 #=====================================================================
4 # Based on SQL-Ledger Version 2.1.9
5 # Web http://www.lx-office.org
7 #=====================================================================
8 # SQL-Ledger Accounting
11 # Author: Dieter Simader
12 # Email: dsimader@sql-ledger.org
13 # Web: http://www.sql-ledger.org
17 # This program is free software; you can redistribute it and/or modify
18 # it under the terms of the GNU General Public License as published by
19 # the Free Software Foundation; either version 2 of the License, or
20 # (at your option) any later version.
22 # This program is distributed in the hope that it will be useful,
23 # but WITHOUT ANY WARRANTY; without even the implied warranty of
24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 # GNU General Public License for more details.
26 # You should have received a copy of the GNU General Public License
27 # along with this program; if not, write to the Free Software
28 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
29 #=====================================================================
31 # user related functions
33 #=====================================================================
45 $main::lxdebug->enter_sub();
47 my ($type, $memfile, $login) = @_;
51 &error("", "$memfile locked!") if (-f "${memfile}.LCK");
53 open(MEMBER, "$memfile") or &error("", "$memfile : $!");
64 # remove any trailing whitespace
67 ($key, $value) = split(/=/, $_, 2);
69 if (($key eq "stylesheet") && ($value eq "sql-ledger.css")) {
70 $value = "lx-office-erp.css";
73 $self->{$key} = $value;
76 $self->{login} = $login;
84 $main::lxdebug->leave_sub();
89 $main::lxdebug->enter_sub();
94 # scan the locale directory and read in the LANGUAGE files
95 opendir(DIR, "locale");
97 my @dir = grep(!/(^\.\.?$|\..*)/, readdir(DIR));
99 foreach my $dir (@dir) {
100 next unless open(FH, "locale/$dir/LANGUAGE");
104 $cc{$dir} = "@language";
109 $main::lxdebug->leave_sub();
115 $main::lxdebug->enter_sub();
117 my ($self, $form, $userspath) = @_;
121 if ($self->{login}) {
123 if ($self->{password}) {
124 if ($form->{hashed_password}) {
125 $form->{password} = $form->{hashed_password};
127 $form->{password} = crypt($form->{password},
128 substr($self->{login}, 0, 2));
130 if ($self->{password} ne $form->{password}) {
131 $main::lxdebug->leave_sub();
136 unless (-e "$userspath/$self->{login}.conf") {
137 $self->create_config("$userspath/$self->{login}.conf");
140 do "$userspath/$self->{login}.conf";
141 $myconfig{dbpasswd} = unpack('u', $myconfig{dbpasswd});
143 # check if database is down
145 DBI->connect($myconfig{dbconnect}, $myconfig{dbuser},
147 or $self->error(DBI::errstr);
149 # we got a connection, check the version
150 my $query = qq|SELECT version FROM defaults|;
151 my $sth = $dbh->prepare($query);
152 $sth->execute || $form->dberror($query);
154 my ($dbversion) = $sth->fetchrow_array;
157 # add login to employee table if it does not exist
158 # no error check for employee table, ignore if it does not exist
159 $query = qq|SELECT id FROM employee WHERE login = ?|;
160 my ($login) = selectrow_query($form, $dbh, $query, $self->{login});
163 $query = qq|INSERT INTO employee (login, name, workphone, role)| .
164 qq|VALUES (?, ?, ?, ?)|;
165 my @values = ($self->{login}, $myconfig{name}, $myconfig{tel}, "user");
166 do_query($form, $dbh, $query, @values);
169 $self->create_schema_info_table($form, $dbh);
176 parse_dbupdate_controls($form, $myconfig{"dbdriver"});
178 map({ $form->{$_} = $myconfig{$_} }
179 qw(dbname dbhost dbport dbdriver dbuser dbpasswd dbconnect));
181 if (update_available($myconfig{"dbdriver"}, $dbversion) ||
182 update2_available($form, $controls)) {
184 $form->{"stylesheet"} = "lx-office-erp.css";
185 $form->{"title"} = $main::locale->text("Dataset upgrade");
187 print($form->parse_html_template("dbupgrade/header"));
189 $form->{dbupdate} = "db$myconfig{dbname}";
190 $form->{ $form->{dbupdate} } = 1;
192 if ($form->{"show_dbupdate_warning"}) {
193 print($form->parse_html_template("dbupgrade/warning"));
198 open(FH, ">$userspath/nologin") or die("$!");
200 # required for Oracle
201 $form->{dbdefault} = $sid;
203 # ignore HUP, QUIT in case the webserver times out
204 $SIG{HUP} = 'IGNORE';
205 $SIG{QUIT} = 'IGNORE';
207 $self->dbupdate($form);
208 $self->dbupdate2($form, $controls);
211 unlink("$userspath/nologin");
214 $self->{"menustyle"} eq "v3" ? "menuv3.pl" :
215 $self->{"menustyle"} eq "neu" ? "menunew.pl" :
218 print($form->parse_html_template("dbupgrade/footer",
219 { "menufile" => $menufile }));
226 $main::lxdebug->leave_sub();
232 $main::lxdebug->enter_sub();
234 my ($form, $db) = @_;
237 'Pg' => { 'yy-mm-dd' => 'set DateStyle to \'ISO\'',
238 'yyyy-mm-dd' => 'set DateStyle to \'ISO\'',
239 'mm/dd/yy' => 'set DateStyle to \'SQL, US\'',
240 'mm-dd-yy' => 'set DateStyle to \'POSTGRES, US\'',
241 'dd/mm/yy' => 'set DateStyle to \'SQL, EUROPEAN\'',
242 'dd-mm-yy' => 'set DateStyle to \'POSTGRES, EUROPEAN\'',
243 'dd.mm.yy' => 'set DateStyle to \'GERMAN\''
246 'yy-mm-dd' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YY-MM-DD\'',
247 'yyyy-mm-dd' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'YYYY-MM-DD\'',
248 'mm/dd/yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM/DD/YY\'',
249 'mm-dd-yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'MM-DD-YY\'',
250 'dd/mm/yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD/MM/YY\'',
251 'dd-mm-yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD-MM-YY\'',
252 'dd.mm.yy' => 'ALTER SESSION SET NLS_DATE_FORMAT = \'DD.MM.YY\'',
255 $form->{dboptions} = $dboptions{ $form->{dbdriver} }{ $form->{dateformat} };
257 if ($form->{dbdriver} eq 'Pg') {
258 $form->{dbconnect} = "dbi:Pg:dbname=$db";
261 if ($form->{dbdriver} eq 'Oracle') {
262 $form->{dbconnect} = "dbi:Oracle:sid=$form->{sid}";
265 if ($form->{dbhost}) {
266 $form->{dbconnect} .= ";host=$form->{dbhost}";
268 if ($form->{dbport}) {
269 $form->{dbconnect} .= ";port=$form->{dbport}";
272 $main::lxdebug->leave_sub();
276 $main::lxdebug->enter_sub();
278 my @drivers = DBI->available_drivers();
280 $main::lxdebug->leave_sub();
282 return (grep { /(Pg|Oracle)/ } @drivers);
286 $main::lxdebug->enter_sub();
288 my ($self, $form) = @_;
293 $form->{dbdefault} = $form->{dbuser} unless $form->{dbdefault};
294 $form->{sid} = $form->{dbdefault};
295 &dbconnect_vars($form, $form->{dbdefault});
298 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
301 if ($form->{dbdriver} eq 'Pg') {
303 qq|SELECT datname FROM pg_database | .
304 qq|WHERE NOT datname IN ('template0', 'template1')|;
305 $sth = $dbh->prepare($query);
306 $sth->execute() || $form->dberror($query);
308 while (my ($db) = $sth->fetchrow_array) {
310 if ($form->{only_acc_db}) {
312 next if ($db =~ /^template/);
314 &dbconnect_vars($form, $db);
316 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
320 qq|SELECT tablename FROM pg_tables | .
321 qq|WHERE (tablename = 'defaults') AND (tableowner = ?)|;
322 my $sth = $dbh->prepare($query);
323 $sth->execute($form->{dbuser}) ||
324 $form->dberror($query . " ($form->{dbuser})");
326 if ($sth->fetchrow_array) {
327 push(@dbsources, $db);
333 push(@dbsources, $db);
337 if ($form->{dbdriver} eq 'Oracle') {
338 if ($form->{only_acc_db}) {
340 qq|SELECT owner FROM dba_objects | .
341 qq|WHERE object_name = 'DEFAULTS' AND object_type = 'TABLE'|;
343 $query = qq|SELECT username FROM dba_users|;
346 $sth = $dbh->prepare($query);
347 $sth->execute || $form->dberror($query);
349 while (my ($db) = $sth->fetchrow_array) {
350 push(@dbsources, $db);
357 $main::lxdebug->leave_sub();
363 $main::lxdebug->enter_sub();
365 my ($self, $form) = @_;
367 $form->{sid} = $form->{dbdefault};
368 &dbconnect_vars($form, $form->{dbdefault});
370 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
372 $form->{db} =~ s/\"//g;
374 'Pg' => qq|CREATE DATABASE "$form->{db}"|,
376 qq|CREATE USER "$form->{db}" DEFAULT TABLESPACE USERS | .
377 qq|TEMPORARY TABLESPACE TEMP IDENTIFIED BY "$form->{db}"|
384 push(@{$dboptions{"Pg"}}, "ENCODING = " . $dbh->quote($form->{"encoding"}))
385 if ($form->{"encoding"});
386 if ($form->{"dbdefault"}) {
387 my $dbdefault = $form->{"dbdefault"};
388 $dbdefault =~ s/[^a-zA-Z0-9_\-]//g;
389 push(@{$dboptions{"Pg"}}, "TEMPLATE = $dbdefault");
392 my $query = $dbcreate{$form->{dbdriver}};
393 $query .= " WITH " . join(" ", @{$dboptions{"Pg"}}) if (@{$dboptions{"Pg"}});
395 do_query($form, $dbh, $query);
397 if ($form->{dbdriver} eq 'Oracle') {
398 $query = qq|GRANT CONNECT, RESOURCE TO "$form->{db}"|;
399 do_query($form, $dbh, $query);
403 # setup variables for the new database
404 if ($form->{dbdriver} eq 'Oracle') {
405 $form->{dbuser} = $form->{db};
406 $form->{dbpasswd} = $form->{db};
409 &dbconnect_vars($form, $form->{db});
411 $dbh = DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
414 my $db_charset = $Common::db_encoding_to_charset{$form->{encoding}};
415 $db_charset ||= Common::DEFAULT_CHARSET;
418 $self->process_query($form, $dbh, "sql/lx-office.sql", undef, $db_charset);
420 # load chart of accounts
421 $self->process_query($form, $dbh, "sql/$form->{chart}-chart.sql", undef, $db_charset);
423 $query = "UPDATE defaults SET coa = ?";
424 do_query($form, $dbh, $query, $form->{chart});
428 $main::lxdebug->leave_sub();
431 # Process a Perl script which updates the database.
432 # If the script returns 1 then the update was successful.
433 # Return code "2" means "needs more interaction; remove
434 # users/nologin and exit".
435 # All other return codes are fatal errors.
436 sub process_perl_script {
437 $main::lxdebug->enter_sub();
439 my ($self, $form, $dbh, $filename, $version_or_control, $db_charset) = @_;
441 my $fh = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
443 my $file_charset = Common::DEFAULT_CHARSET;
445 if (ref($version_or_control) eq "HASH") {
446 $file_charset = $version_or_control->{charset};
451 next if !/^--\s*\@charset:\s*(.+)/;
455 $fh->seek(0, SEEK_SET);
458 my $contents = join "", <$fh>;
461 $db_charset ||= Common::DEFAULT_CHARSET;
463 my $iconv = Text::Iconv->new($file_charset, $db_charset);
467 my %dbup_myconfig = ();
468 map({ $dbup_myconfig{$_} = $form->{$_}; }
469 qw(dbname dbuser dbpasswd dbhost dbport dbconnect));
471 my $nls_file = $filename;
472 $nls_file =~ s|.*/||;
473 $nls_file =~ s|.pl$||;
474 my $dbup_locale = Locale->new($main::language, $nls_file);
476 my $result = eval($contents);
483 if (!defined($result)) {
484 print($form->parse_html_template("dbupgrade/error",
485 { "file" => $filename,
488 } elsif (1 != $result) {
489 unlink("users/nologin") if (2 == $result);
493 if (ref($version_or_control) eq "HASH") {
494 $dbh->do("INSERT INTO schema_info (tag, login) VALUES (" .
495 $dbh->quote($version_or_control->{"tag"}) . ", " .
496 $dbh->quote($form->{"login"}) . ")");
497 } elsif ($version_or_control) {
498 $dbh->do("UPDATE defaults SET version = " .
499 $dbh->quote($version_or_control));
503 $main::lxdebug->leave_sub();
507 $main::lxdebug->enter_sub();
509 my ($self, $form, $dbh, $filename, $version_or_control, $db_charset) = @_;
511 my $fh = IO::File->new($filename, "r") or $form->error("$filename : $!\n");
516 my $file_charset = Common::DEFAULT_CHARSET;
519 next if !/^--\s*\@charset:\s*(.+)/;
523 $fh->seek(0, SEEK_SET);
525 $db_charset ||= Common::DEFAULT_CHARSET;
527 my $iconv = Text::Iconv->new($file_charset, $db_charset);
532 $_ = $iconv->convert($_);
534 # Remove DOS and Unix style line endings.
540 for (my $i = 0; $i < length($_); $i++) {
541 my $char = substr($_, $i, 1);
543 # Are we inside a string?
545 if ($char eq $quote_chars[-1]) {
551 if (($char eq "'") || ($char eq "\"")) {
552 push(@quote_chars, $char);
554 } elsif ($char eq ";") {
556 # Query is complete. Send it.
558 $sth = $dbh->prepare($query);
559 if (!$sth->execute()) {
560 my $errstr = $dbh->errstr;
563 $form->dberror("The database update/creation did not succeed. " .
564 "The file ${filename} containing the following " .
565 "query failed:<br>${query}<br>" .
566 "The error message was: ${errstr}<br>" .
567 "All changes in that file have been reverted.");
580 if (ref($version_or_control) eq "HASH") {
581 $dbh->do("INSERT INTO schema_info (tag, login) VALUES (" .
582 $dbh->quote($version_or_control->{"tag"}) . ", " .
583 $dbh->quote($form->{"login"}) . ")");
584 } elsif ($version_or_control) {
585 $dbh->do("UPDATE defaults SET version = " .
586 $dbh->quote($version_or_control));
592 $main::lxdebug->leave_sub();
596 $main::lxdebug->enter_sub();
598 my ($self, $form) = @_;
599 $form->{db} =~ s/\"//g;
600 my %dbdelete = ('Pg' => qq|DROP DATABASE "$form->{db}"|,
601 'Oracle' => qq|DROP USER "$form->{db}" CASCADE|);
603 $form->{sid} = $form->{dbdefault};
604 &dbconnect_vars($form, $form->{dbdefault});
606 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
608 my $query = $dbdelete{$form->{dbdriver}};
609 do_query($form, $dbh, $query);
613 $main::lxdebug->leave_sub();
616 sub dbsources_unused {
617 $main::lxdebug->enter_sub();
619 my ($self, $form, $memfile) = @_;
624 $form->error('File locked!') if (-f "${memfile}.LCK");
627 open(FH, "$memfile") or $form->error("$memfile : $!");
631 my ($null, $item) = split(/=/);
638 $form->{only_acc_db} = 1;
639 my @db = &dbsources("", $form);
641 push @dbexcl, $form->{dbdefault};
643 foreach $item (@db) {
644 unless (grep /$item$/, @dbexcl) {
645 push @dbsources, $item;
649 $main::lxdebug->leave_sub();
655 $main::lxdebug->enter_sub();
657 my ($self, $form) = @_;
662 $form->{sid} = $form->{dbdefault};
663 &dbconnect_vars($form, $form->{dbdefault});
666 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
669 if ($form->{dbdriver} eq 'Pg') {
672 qq|SELECT d.datname FROM pg_database d, pg_user u | .
673 qq|WHERE d.datdba = u.usesysid AND u.usename = ?|;
674 my $sth = prepare_execute_query($form, $dbh, $query, $form->{dbuser});
676 while (my ($db) = $sth->fetchrow_array) {
678 next if ($db =~ /^template/);
680 &dbconnect_vars($form, $db);
683 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
687 qq|SELECT tablename FROM pg_tables | .
688 qq|WHERE tablename = 'defaults'|;
689 my $sth2 = prepare_execute_query($form, $dbh, $query);
691 if ($sth2->fetchrow_array) {
692 $query = qq|SELECT version FROM defaults|;
693 my ($version) = selectrow_query($form, $dbh2, $query);
694 $dbsources{$db} = $version;
702 if ($form->{dbdriver} eq 'Oracle') {
704 qq|SELECT owner FROM dba_objects |.
705 qq|WHERE object_name = 'DEFAULTS' AND object_type = 'TABLE'|;
707 $sth = $dbh->prepare($query);
708 $sth->execute || $form->dberror($query);
710 while (my ($db) = $sth->fetchrow_array) {
712 $form->{dbuser} = $db;
713 &dbconnect_vars($form, $db);
716 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
719 $query = qq|SELECT version FROM defaults|;
720 my $sth = $dbh->prepare($query);
723 if (my ($version) = $sth->fetchrow_array) {
724 $dbsources{$db} = $version;
734 $main::lxdebug->leave_sub();
740 $main::lxdebug->enter_sub(2);
742 my (@v, $version, $i);
744 @v = split(/\./, $_[0]);
745 while (scalar(@v) < 4) {
749 for ($i = 0; $i < 4; $i++) {
754 $main::lxdebug->leave_sub(2);
758 sub cmp_script_version {
759 my ($a_from, $a_to, $b_from, $b_to);
760 my ($i, $res_a, $res_b);
761 my ($my_a, $my_b) = ($a, $b);
763 $my_a =~ s/.*-upgrade-//;
765 $my_b =~ s/.*-upgrade-//;
767 ($my_a_from, $my_a_to) = split(/-/, $my_a);
768 ($my_b_from, $my_b_to) = split(/-/, $my_b);
770 $res_a = calc_version($my_a_from);
771 $res_b = calc_version($my_b_from);
773 if ($res_a == $res_b) {
774 $res_a = calc_version($my_a_to);
775 $res_b = calc_version($my_b_to);
778 return $res_a <=> $res_b;
781 sub update_available {
782 my ($dbdriver, $cur_version) = @_;
784 opendir(SQLDIR, "sql/${dbdriver}-upgrade")
785 or &error("", "sql/${dbdriver}-upgrade: $!");
787 grep(/$form->{dbdriver}-upgrade-\Q$cur_version\E.*\.(sql|pl)$/,
791 return ($#upgradescripts > -1);
794 sub create_schema_info_table {
795 $main::lxdebug->enter_sub();
797 my ($self, $form, $dbh) = @_;
799 my $query = "SELECT tag FROM schema_info LIMIT 1";
800 if (!$dbh->do($query)) {
803 qq|CREATE TABLE schema_info (| .
806 qq| itime timestamp DEFAULT now(), | .
807 qq| PRIMARY KEY (tag))|;
808 $dbh->do($query) || $form->dberror($query);
811 $main::lxdebug->leave_sub();
815 $main::lxdebug->enter_sub();
817 my ($self, $form) = @_;
819 $form->{sid} = $form->{dbdefault};
821 my @upgradescripts = ();
825 if ($form->{dbupdate}) {
827 # read update scripts into memory
828 opendir(SQLDIR, "sql/" . $form->{dbdriver} . "-upgrade")
829 or &error("", "sql/" . $form->{dbdriver} . "-upgrade : $!");
831 sort(cmp_script_version
832 grep(/$form->{dbdriver}-upgrade-.*?\.(sql|pl)$/,
837 my $db_charset = $main::dbcharset;
838 $db_charset ||= Common::DEFAULT_CHARSET;
840 foreach my $db (split(/ /, $form->{dbupdate})) {
842 next unless $form->{$db};
844 # strip db from dataset
846 &dbconnect_vars($form, $db);
849 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
853 $query = qq|SELECT version FROM defaults|;
854 my ($version) = selectrow_query($form, $dbh, $query);
856 next unless $version;
858 $version = calc_version($version);
860 foreach my $upgradescript (@upgradescripts) {
861 my $a = $upgradescript;
862 $a =~ s/^$form->{dbdriver}-upgrade-|\.(sql|pl)$//g;
865 my ($mindb, $maxdb) = split /-/, $a;
866 my $str_maxdb = $maxdb;
867 $mindb = calc_version($mindb);
868 $maxdb = calc_version($maxdb);
870 next if ($version >= $maxdb);
872 # if there is no upgrade script exit
873 last if ($version < $mindb);
876 $main::lxdebug->message(DEBUG2, "Applying Update $upgradescript");
877 if ($file_type eq "sql") {
878 $self->process_query($form, $dbh, "sql/" . $form->{"dbdriver"} .
879 "-upgrade/$upgradescript", $str_maxdb, $db_charset);
881 $self->process_perl_script($form, $dbh, "sql/" . $form->{"dbdriver"} .
882 "-upgrade/$upgradescript", $str_maxdb, $db_charset);
894 $main::lxdebug->leave_sub();
900 $main::lxdebug->enter_sub();
902 my ($self, $form, $controls) = @_;
904 $form->{sid} = $form->{dbdefault};
906 my @upgradescripts = ();
907 my ($query, $sth, $tag);
910 @upgradescripts = sort_dbupdate_controls($controls);
912 my $db_charset = $main::dbcharset;
913 $db_charset ||= Common::DEFAULT_CHARSET;
917 foreach my $db (split / /, $form->{dbupdate}) {
919 next unless $form->{$db};
921 # strip db from dataset
923 &dbconnect_vars($form, $db);
926 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd})
929 map({ $_->{"applied"} = 0; } @upgradescripts);
931 $query = qq|SELECT tag FROM schema_info|;
932 $sth = $dbh->prepare($query);
933 $sth->execute() || $form->dberror($query);
934 while (($tag) = $sth->fetchrow_array()) {
935 $controls->{$tag}->{"applied"} = 1 if (defined($controls->{$tag}));
940 foreach (@upgradescripts) {
941 if (!$_->{"applied"}) {
947 next if ($all_applied);
949 foreach my $control (@upgradescripts) {
950 next if ($control->{"applied"});
952 if (!$converters{$control->{charset}}) {
953 $converters{$control->{charset}} = Text::Iconv->new($control->{charset}, $db_charset);
955 $control->{description} = $converters{$control->{charset}}->convert($control->{description});
957 $control->{"file"} =~ /\.(sql|pl)$/;
961 $main::lxdebug->message(DEBUG2, "Applying Update $control->{file}");
962 print($form->parse_html_template("dbupgrade/upgrade_message2",
965 if ($file_type eq "sql") {
966 $self->process_query($form, $dbh, "sql/" . $form->{"dbdriver"} .
967 "-upgrade2/$control->{file}", $control, $db_charset);
969 $self->process_perl_script($form, $dbh, "sql/" . $form->{"dbdriver"} .
970 "-upgrade2/$control->{file}", $control, $db_charset);
979 $main::lxdebug->leave_sub();
984 sub update2_available {
985 $main::lxdebug->enter_sub();
987 my ($form, $controls) = @_;
989 map({ $_->{"applied"} = 0; } values(%{$controls}));
991 dbconnect_vars($form, $form->{"dbname"});
994 DBI->connect($form->{dbconnect}, $form->{dbuser}, $form->{dbpasswd}) ||
997 my ($query, $tag, $sth);
999 $query = qq|SELECT tag FROM schema_info|;
1000 $sth = $dbh->prepare($query);
1001 $sth->execute() || $form->dberror($query);
1002 while (($tag) = $sth->fetchrow_array()) {
1003 $controls->{$tag}->{"applied"} = 1 if (defined($controls->{$tag}));
1008 map({ $main::lxdebug->leave_sub() and return 1 if (!$_->{"applied"}) }
1009 values(%{$controls}));
1011 $main::lxdebug->leave_sub();
1016 $main::lxdebug->enter_sub();
1018 my ($self, $filename) = @_;
1020 @config = &config_vars;
1022 open(CONF, ">$filename") or $self->error("$filename : $!");
1024 # create the config file
1025 print CONF qq|# configuration file for $self->{login}
1030 foreach $key (sort @config) {
1031 $self->{$key} =~ s/\'/\\\'/g;
1032 print CONF qq| $key => '$self->{$key}',\n|;
1035 print CONF qq|);\n\n|;
1039 $main::lxdebug->leave_sub();
1043 $main::lxdebug->enter_sub();
1045 my ($self, $memberfile, $userspath) = @_;
1049 # format dbconnect and dboptions string
1050 &dbconnect_vars($self, $self->{dbname});
1052 $self->error('File locked!') if (-f "${memberfile}.LCK");
1053 open(FH, ">${memberfile}.LCK") or $self->error("${memberfile}.LCK : $!");
1056 open(CONF, "+<$memberfile") or $self->error("$memberfile : $!");
1063 while ($line = shift @config) {
1064 if ($line =~ /^\[$self->{login}\]/) {
1071 # remove everything up to next login or EOF
1072 while ($line = shift @config) {
1073 last if ($line =~ /^\[/);
1076 # this one is either the next login or EOF
1079 while ($line = shift @config) {
1083 print CONF qq|[$self->{login}]\n|;
1085 if ((($self->{dbpasswd} ne $self->{old_dbpasswd}) || $newmember)
1087 $self->{dbpasswd} = pack 'u', $self->{dbpasswd};
1088 chop $self->{dbpasswd};
1090 if (defined($self->{new_password})) {
1091 if ($self->{new_password} ne $self->{old_password}) {
1092 $self->{password} = crypt $self->{new_password},
1093 substr($self->{login}, 0, 2)
1094 if $self->{new_password};
1097 if ($self->{password} ne $self->{old_password}) {
1098 $self->{password} = crypt $self->{password}, substr($self->{login}, 0, 2)
1099 if $self->{password};
1103 if ($self->{'root login'}) {
1104 @config = ("password");
1106 @config = &config_vars;
1109 # replace \r\n with \n
1110 map { $self->{$_} =~ s/\r\n/\\n/g } qw(address signature);
1111 foreach $key (sort @config) {
1112 print CONF qq|$key=$self->{$key}\n|;
1117 unlink "${memberfile}.LCK";
1120 $self->create_config("$userspath/$self->{login}.conf")
1121 unless $self->{'root login'};
1123 $main::lxdebug->leave_sub();
1127 $main::lxdebug->enter_sub();
1129 my @conf = qw(acs address admin businessnumber company countrycode
1130 currency dateformat dbconnect dbdriver dbhost dbport dboptions
1131 dbname dbuser dbpasswd email fax name numberformat password
1132 printer role sid signature stylesheet tel templates vclimit angebote
1133 bestellungen rechnungen anfragen lieferantenbestellungen einkaufsrechnungen
1134 taxnumber co_ustid duns menustyle template_format default_media
1135 default_printer_id copies show_form_details);
1137 $main::lxdebug->leave_sub();
1143 $main::lxdebug->enter_sub();
1145 my ($self, $msg) = @_;
1147 if ($ENV{HTTP_USER_AGENT}) {
1148 print qq|Content-Type: text/html
1150 <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN">
1152 <body bgcolor=ffffff>
1154 <h2><font color=red>Error!</font></h2>
1159 die "Error: $msg\n";
1161 $main::lxdebug->leave_sub();