1#!/usr/bin/perl -I/home/klaus/Work/WWWdb 2#!/usr/bin/perl 3#!/usr/bin/speedy -- -r10 -t600 4#!/usr/bin/perl -d:DProf 5# -*-perl-*- 6# ----------------------------------------------------------------------------- 7# 8# Copyright (c) 1999-2002 by Klaus Reger <K.Reger@wwwdb.org> 9# 10# You may distribute under the terms of either the GNU General Public 11# License or the Artistic License, as specified in the Perl README file. 12# 13# THIS IS BETA SOFTWARE! 14# 15# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR 16# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED 17# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 18# 19# $Id: WWWdb.cgi,v 1.49 2003/04/16 11:25:21 k_reger Exp $ 20# 21# ----------------------------------------------------------------------------- 22# Program-Data 23# ----------------------------------------------------------------------------- 24# Project : 25# System : 26# Program : 27# Module : $RCSfile: WWWdb.cgi,v $ 28# Version : $Revision: 1.49 $ 29# Date : $Date: 2003/04/16 11:25:21 $ 30# State : $State: Exp $ 31# 32# Description: 33# This script allows, to insert, update and delete records of 34# a Database over the WWW 35# 36# 37# State-Flows: 38# --------------------------------------------------------------------------- 39# By Default, the following states are implemented 40# 41# State SubState Exits LeadsTo Comment 42# Init Ok New Init Insert Record, Clear form, Jump back 43# Error New Init Show Err-Messages 44# - Qry Qry Selection of date, internal navigation 45# - Back Init Clear form, Jump back 46# Qry - Sel_x Work Show sel. record 47# - Back Init Clear form, Jump back 48# Work Error Upd Upd Show Err-Messages 49# Ok Upd Init Change Record, Clear form, Jump back 50# - Del Init Del record, Clear form, Jump back 51# - Back Init Clear form, Jump back 52# 53# ----------------------------------------------------------------------------- 54# Change-log (See at end of this file) 55# 56# --- Known Bugs ------------- 57# please look at the BUGS-File 58# --- TODO ------------------- 59# please look at the TODO-File 60# ---------------------------------------------------------------------------- 61 62use strict; 63use locale; 64# use diagnostics; 65 66use POSIX qw(); 67 68use CGI::Carp qw(fatalsToBrowser); 69use CGI::Cache; 70 71use DB_File; 72 73use DBIx::Recordset; # SQL-access via recordsets 74 75use Digest::MD5 qw(md5_hex); # Create md5-hashes 76 77use HTML::Entities; # HTML-conversions (� -> ü) 78use HTML::Template; # HTML-Template 79 80use vars qw($VERSION 81 $cBgColorMGL 82 $cBgImageMGL 83 $hQryMGL 84 $iCacheTimeoutMGL 85 $iDevelopmentVersionMGL 86 $lFieldLayoutMGL 87 $oConfPoolGL 88 $oDbSessionGL 89 $oDbTargetGL 90 $oFormMGL 91 $oSessionGL 92 $pDataSetMGL 93 $pDbHdlMGL 94 %hFieldErrorsMGL 95 %hFormDataMGL 96 %hTableInfoMGL 97 %hSelectCacheMGL 98 @pDataSetMGL 99 %hCategoriesGL 100 %hMessagesGL 101 ); 102 103use WWWdb::Base; # Base methods for WWWdb 104use WWWdb::HTML; # HTML-related methods for WWWdb 105use WWWdb::Session; # Session-related methods for WWWdb 106use WWWdb::Plugin; # Plugin-methods for WWWdb 107use WWWdb::DbSession; # Database-Session for WWWdb 108use WWWdb::ConfigPool; # Config-File-Pools for WWWdb 109use WWWdb::ConfigFile; # Config-Files for WWWdb 110 111# use WWWdb::Monitor; # Monitoring variables 112 113=head1 NAME 114 115WWWdb-API - Interface to WWWdb to use in your plugins 116 117=head1 SYNOPSIS 118 119ClearFields - clear all entry-fields 120 121OkForm - Display a form similar to a popup-window 122 123Error - show a error-frame and leave 124 125MyExit - leave WWWdb in a clean way 126 127MyUserVal - Get an entry of the config-file, but look for session-data before 128 129MyVal - Get an entry of the config-file 130 131MySetVal - Set an entry, defined in the config-file 132 133Redirect - redirect the browser to another HTML-page 134 135CreateReference - makes an internal WWWdb-HTML-reference 136 137ResolveRefField - Resolve a Reference of an wwwdb_object 138 139GetField - Get value of a Field in the HTML-Form 140 141SetField - Sets the value of a HTML-field 142 143AddError - Add an error-message to the internal list 144 145DecodeHtml - decodes HTML-formatted entities to normal Text 146 147EncodeHtml - encode normal text, to be HTML-save 148 149SafeEncodeHtml - extended encoding of HTML-Tags 150 151GetFieldTypeName - get the fieldtype-name of a given field 152 153SQLSelectList - Get the SQL-SELECT-result as a list 154 155SQLDo - executes the given SQL-statement 156 157GetAttr - Get some internal WWWdb-attributes 158 159=head1 DESCRIPTION 160 161WWWdb-API is a interface to the WWWdb-application. This application 162enables you to maintain the data of a database-table over the WWW. To 163keep the data consistent, maybe you need to write some plugins, which 164check data-integrity. 165 166Because it is included in WWWdb, you should normally NOT include it in 167your scripts. Your scripts are included in WWWdb, and this Library 168gives you a interface to the internals of WWWdb. 169 170=head1 FUNCTIONS 171 172=cut 173 174 175 176# --- This routine is called at compilation-time ---------------------------- 177sub BEGIN () 178{ 179 my $cBasePath; 180 181 $VERSION = '0.8.3'; 182 $iDevelopmentVersionMGL = 0; 183 184 delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer 185 186 if ($iDevelopmentVersionMGL && 187 &UnTaint($ENV{"HTTP_PRAGMA"})) 188 { 189 require Data::Dumper; # Pretty-print data-structs for debug 190 require CGI; 191 192 require CGI::Debug; 193 import CGI::Debug(report => ['errors', 'time', 194 'params', 'cookies', 195 'environment', 196 'everything'], 197 on => ['anything'], 198 to => { browser => 1 }, 199 header => 'ignore', 200 set => { 201 param_length => 512, 202 error_document => 'oups.html' } 203 ); 204 205 require Carp::Assert; 206 207 # require CGI::Pretty; 208 CGI->import(qw(:standard :html3 -debug)); # CGI-functionality 209 210 $main::SIG{'__WARN__'} = \&MyDie; 211 212 } 213 else 214 { 215 require CGI; 216 CGI->import(qw(:standard :html3)); # CGI-functionality 217 } 218 219 $main::SIG{'__DIE__'} = \&MyDie; 220 $main::SIG{'SEGV'} = \&MyDie; 221 $main::SIG{'BUS'} = \&MyDie; 222 223} # BEGIN 224 225 226sub END() 227{ 228 untie %hMessagesGL; 229} 230 231 232 233 234# --- Initializations ----------------------------------------------------------- 235sub InitVars() 236{ 237 my $cKey; 238 my $cCacheFileName; 239 my $cCGIParamKey = ""; 240 241 $hQryMGL = new CGI; # CGI-Query-Set 242 $hQryMGL->autoEscape(undef); 243 244 %hFormDataMGL = (); 245 %hTableInfoMGL = (); 246 %hSelectCacheMGL = (); 247 248 # Monitor::monitor(\%hFormDataMGL, 'hFormDataMGL'); 249 250 close STDERR; 251 open(STDERR, ">" . &GetAttr("LogfileName")) or 252 print STDERR ("Unable to open " . &GetAttr("LogfileName") . " for Output: $!\n"); 253 254 # Form-Parameters in Hash 255 foreach $cKey ($hQryMGL->param) 256 { 257 # FIXME: This makes multiple selections appear, but makes 258 # trouble with some single fields 259 $hFormDataMGL{$cKey} = join "\\,", $hQryMGL->param($cKey); 260 # $hFormDataMGL{$cKey} = $hQryMGL->param($cKey); 261 $cCGIParamKey .= "$cKey=" . $hQryMGL->param($cKey); 262 } 263 264 print STDERR $hQryMGL->Dump() 265 if &GetAttr("DebugLvl") > 4; 266 267 $cCGIParamKey = $hQryMGL->param? md5_hex($cCGIParamKey) : "0"; 268 # $cCGIParamKey =~ s/\W//g; # For tests only 269 270 $cCacheFileName = sprintf ('%s/tmp/cache/%s/%s/%s/%s-%s-%s.html', 271 &UnTaint($ENV{"WWWDB_BASE_PATH"}), 272 &GetAttr("DbDriver"), 273 &GetAttr("SessionId"), 274 &GetAttr("ConfigPath"), 275 &MyParam("WWWdbState"), 276 &GetAttr("UrlParams"), 277 $cCGIParamKey), 278 279 $cCacheFileName =~ s/[!\"\\;=&,\']/_/g; 280 281 $iCacheTimeoutMGL = 0; 282 283 &Plugin::_UndefAllPlugins(); 284 285 { 286 if (&GetAttr("DebugLvl")) 287 { 288 foreach (keys %ENV) 289 { 290 print STDERR "ENV->$_ = $ENV{$_}\n"; 291 } 292 } 293 294 my $cBasePath = (&UnTaint($ENV{"WWWDB_BASE_PATH"})? 295 &UnTaint($ENV{"WWWDB_BASE_PATH"}): 296 &UnTaint($ENV{"DOCUMENT_ROOT"}) . "/WWWdb"); 297 298 foreach (# the Pre-plugin functionality 299 "WWWdb/Pre", 300 301 # Pre-Domain 302 ("WWWdb/Pre" . 303 (&UnTaint($ENV{"WWWDB_DOMAIN"})? 304 &UnTaint($ENV{"WWWDB_DOMAIN"}): 305 "WWWdb")), 306 307 # Database-related scripts 308 ("WWWdb/Db/" . 309 (&UnTaint($ENV{"WWWDB_DATABASE"})? 310 &UnTaint($ENV{"WWWDB_DATABASE"}): 311 "Default")), 312 313 # The application-script 314 (&UnTaint($ENV{"WWWDB_CONFIG_FILE"})? 315 &UnTaint($ENV{"WWWDB_CONFIG_FILE"}): 316 "WWWdb/Index"), 317 318 # Post-Domain 319 ("WWWdb/Post" . 320 (&UnTaint($ENV{"WWWDB_DOMAIN"})? 321 &UnTaint($ENV{"WWWDB_DOMAIN"}): 322 "WWWdb")), 323 324 # the Post-plugin functionality 325 "WWWdb/Post") 326 { 327 my $cConfigFile = &UnTaint($_); 328 329 # If the entry is a directory, use the Index.pl script 330 $cConfigFile .= "/Index" 331 if(-d sprintf("%s/lib/%s", $cBasePath, $cConfigFile)); 332 333 334 # --- include here your own application-code in the .pl-Source ---------------- 335 { 336 my $cPerlSource = &UnTaint(sprintf("%s/lib/%s.pl", 337 $cBasePath, 338 $cConfigFile)); 339 340 if (-f $cPerlSource) 341 { 342 if (-r $cPerlSource) 343 { 344 if(eval 345 { 346 do $cPerlSource; 347 }) 348 { 349 print STDERR "do $cPerlSource\n" 350 if &GetAttr("DebugLvl") > 2; 351 } 352 else 353 { 354 print STDERR "do $cPerlSource failed\n" 355 if &GetAttr("DebugLvl") > 2; 356 } 357 } 358 else 359 { 360 die(sprintf(i18n("Sorry, but the plugin-source %s ". 361 "is not readable!"), 362 br() x 2 . 363 (big(b($cPerlSource))) . 364 br() x 2)); 365 } 366 } 367 } 368 } 369 } 370 371 # Actualize the Sym-Table-Cache 372 &Plugin::_Init_SymTableCache(); 373 374 $Data::Dumper::Indent = 1; # mild pretty print 375 376 # my $hConfDataMGL = (); 377 $cBgColorMGL = undef; 378 $cBgImageMGL = undef; 379 $oFormMGL = undef; 380 $oSessionGL = undef; 381 $oConfPoolGL = undef; 382 383 { 384 my $cPathOfConfigFile = 385 &GetAttr("ConfigPath"); 386 387 # Remove last element of Path 388 $cPathOfConfigFile =~ s./[^/]+..; 389 390 # ConfigFileName ReadOnly MustExist 391 my @lConfigFileData = 392 (["WWWdb/Pre", 1, 0], 393 ["WWWdb/Pre" . &GetAttr("WWWdbDomain"), 1, 0], 394 [&GetAttr("ConfigPath"), 0, 1], 395 ["WWWdb/Db/" . &GetAttr("DbDriver"), 1, 1], 396 ["WWWdb/Post" . &GetAttr("WWWdbDomain"), 1, 0], 397 ["WWWdb/Post", 1, 0]); 398 399 my $cConfigFileEntry; 400 401 $oConfPoolGL = ConfigPool->new("DebugLvl" => &GetAttr("DebugLvl")); 402 403 foreach $cConfigFileEntry (@lConfigFileData) 404 { 405 my $oConfigFile; 406 my $cConfigFilename = sprintf("%s/lib/%s.rc", 407 &GetAttr("BaseDir"), 408 $cConfigFileEntry->[0]); 409 410 if((! -f $cConfigFilename) && $cConfigFileEntry->[2]) 411 { 412 die(sprintf(i18n("Sorry, but the config-file %s does not exist!"), 413 br() x 2 . 414 (big(b($cConfigFilename))) . 415 br() x 2)); 416 } 417 418 if((! -r $cConfigFilename) && $cConfigFileEntry->[2]) 419 { 420 die(sprintf(i18n("Sorry, but the config-file %s is not readable!"), 421 br() x 2 . 422 (big(b($cConfigFilename))) . 423 br() x 2)); 424 } 425 426 $oConfigFile = ConfigFile->new 427 ($cConfigFilename, 428 "ReadOnly" => $cConfigFileEntry->[1], 429 "MustExist" => $cConfigFileEntry->[2], 430 "DebugLvl" => 0 431 ); 432 433 $oConfPoolGL->addConfigFile($oConfigFile); 434 435 } 436 } 437 438 $oConfPoolGL->Dump() 439 if &GetAttr("DebugLvl"); 440 441 442 $iCacheTimeoutMGL = &MyVal('Cache', 'Timeout', 0); 443 444 if ($iCacheTimeoutMGL) 445 { 446 &CGI::Cache::SetFile($cCacheFileName, $iCacheTimeoutMGL); 447 &CGI::Cache::Start(); 448 } 449 else 450 { 451 $hQryMGL->cache("no"); 452 } 453} 454 455 456 457 458# --- Main-Routine ----------------------------------------------------------- 459sub Main() 460{ 461 my $cBtn; 462 463 # set real uid to effective uid 464 # $< = $>; 465 # set real gid to effective gid 466 # $( = $); 467 468 &InitVars(); 469 470 &InitDb(); 471 &InitForm(); 472 473 &DebugFormData() 474 if &GetAttr("DebugLvl") > 2; 475 476 printf STDERR "Config-file: %s\n", &GetAttr("ConfigPath") 477 if &GetAttr("DebugLvl") > 2; 478 479 &MyParam("WWWdbLastUrlParam", &GetAttr("UrlParams")) 480 if &GetAttr("UrlParams") > 2; 481 482 printf STDERR "URL-Params: %s\n", &MyParam('WWWdbLastUrlParam') 483 if &GetAttr("DebugLvl") > 2; 484 485 $cBtn = &GetAttr("LastBtn"); 486 487 # Another language was choosen 488 if ($cBtn =~ /^Btn_SelLang$/) 489 { 490 491 # in anonymous-mode: change the session-id 492 if($oSessionGL->getState("IsAnonymous")) 493 { 494 my $iNewSessionId; 495 496 # get the anonymous-session-id for the new language 497 $iNewSessionId = $oDbSessionGL->SqlSelect 498 ("SELECT 499 s1.session_id 500 FROM 501 wwwdb_state s1, 502 wwwdb_state s2 503 WHERE 504 s1.key_name = '[WWWdb] Lang' AND 505 s1.key_value = ? AND 506 s2.key_name = 'IsAnonymous' AND 507 s2.key_value != '' AND 508 s1.session_id = s2.session_id", 509 &GetField("_SelLang"))->[0]->[0]; 510 511 &Redirect($iNewSessionId, "WWWdb:Index") 512 if $iNewSessionId; 513 } 514 # change the preferences 515 else 516 { 517 518 $oSessionGL->setState("[WWWdb] Lang", 519 &GetField("_SelLang")); 520 521# FIXME: This does not work here :-( don't know why (yet) 522# print &Redirect(&GetAttr("SessionId"), 523# (&GetAttr("ConfigFile") . 524# ";" . 525# &MyParam('WWWdbLastUrlParam'))); 526 527 &OkForm("", i18n("Language will change " . 528 "after pressing the OK-button!")); 529 &MyExit(); 530 } 531 } 532 533 # Search for a word 534 elsif ($cBtn =~ /^Btn_Search$/ || &GetField("_Search")) 535 { 536 537 { 538 &Redirect(&GetAttr("SessionId"), 539 ("WWWdb:Nav;sword=*" . 540 &GetField("_Search") . 541 "*")); 542 } 543 } 544 545 Plugin->new("PreDoAction")->Call(); 546 547 &HavePermissionToRun(); 548 549 # decide what to do next 550 &FindActionToDo(); 551 552 &MyExit(); 553} 554 555 556# --- Initialize data in form ------------------------------------------------ 557sub InitDb () 558{ 559 my $cKey; 560 my @lDateScanFormats = &MyListVal('DB', 'DateScanFormats'); 561 562 # set params for DBIx::Recordset 563 &MyParam("!Database", &MyVal('DB', 'Database') ) 564 if !defined($hFormDataMGL{"!Database"}); 565 566 &MyParam("!Username", &MyVal('DB', 'Username')) 567 if !defined($hFormDataMGL{"!Username"}); 568 569 &MyParam("!Password", &MyVal('DB', 'Password')) 570 if !defined($hFormDataMGL{"!Password"}); 571 572 # --- Database-specific options ------------------------------------------- 573 $oDbSessionGL = DbSession->new 574 (&MyVal('DB', 'Driver', 'Default'), # FIXME: Replace Default 575 &MyParam("!Database"), 576 &MyParam("!Username"), 577 &MyParam("!Password"), 578 "DbHost" => &MyVal('DB', 'Host', "localhost"), 579 "DebugLvl" => &GetAttr("DebugLvl"), 580 "Lang" => &GetAttr("BaseLang"), 581 "DatePrintFormat" => i18n(&MyVal('DB', 'DatePrintFormat', 582 "%Y-%m-%d %H:%M:%S")), 583 (@lDateScanFormats ? 584 ("DateScanFormats" => \@lDateScanFormats): 585 undef)); 586 587 # check for a target database 588 if (&MyVal('TargetDB', 'Database')) 589 { 590 # set params for DBIx::Recordset 591 &MyParam("!Database", &MyVal('TargetDB', 'Database')); 592 &MyParam("!Username", &MyVal('TargetDB', 'Username')); 593 &MyParam("!Password", &MyVal('TargetDB', 'Password')); 594 595 $oDbTargetGL = DbSession->new 596 (&MyVal('DB', 'Driver', 'Default'), 597 &MyParam("!Database"), 598 &MyParam("!Username"), 599 &MyParam("!Password"), 600 "DbHost" => &MyVal('TargetDB', 'Host', "localhost"), 601 "DebugLvl" => &GetAttr("DebugLvl"), 602 "Lang" => &GetAttr("BaseLang"), 603 "DatePrintFormat" => i18n(&MyVal('TargetDB', 'DatePrintFormat', 604 "%Y-%m-%d %H:%M:%S")), 605 (@lDateScanFormats ? 606 ("DateScanFormats" => \@lDateScanFormats): 607 undef)); 608 } 609 else 610 { 611 $oDbTargetGL = $oDbSessionGL; 612 } 613 614 &MyParam("!DataSource", $oDbTargetGL->getDataSource()); 615 616 # make a standard connection to the database 617 $pDbHdlMGL = $oDbSessionGL->getDbHandle(); 618 619 &Error(sprintf(i18n("The Id-Field (which defines a global unique " . 620 "key for every record in the database " . 621 "is not set!") . 622 "<BR><BR>" . 623 i18n("Insert the correct name of the id-field " . 624 "in the config-file " . 625 "under the section %s with:") . 626 "<BR>" . 627 "%s", 628 b("[DB]"), 629 b("IdField = <name><BR>"))) 630 if !&GetAttr("RecIdField"); 631 632} 633 634 635# --- initialize data for DBIx::Recordset ----------------------------------- 636sub InitDBIxRecordset() 637{ 638 *DBIx::Recordset::LOG = \*STDERR; 639 $DBIx::Recordset::Debug = &GetAttr("DebugLvl")? 3: 1; 640 641 &MyParam('$max', &MyVal('Browser', 'MaxRows', 5)); 642 &MyParam('$valuesplit', ","); 643 &MyParam('$compconj', "and"); 644 &MyParam('!DBIAttr', {LongReadLen => 256 * 1024, 645 LongTruncOk => 1}); 646 647 &MyParam('$start', "0") 648 unless &MyParam('$start'); 649 650 &MyParam("!Table", &MyVal('Data', 'Table')); 651 652 &MyParam("!Order", &MyVal('Data', 'Order', '')) 653 unless defined &MyParam('!Order'); 654 655 # 0 -> undef = SQL:NULL 656 # 1 -> undef fields are ignored, 657 # 2 -> undef or empty fields are ignored 658 &MyParam("!IgnoreEmpty", "0"); # FIXME: IgnoreEmpty 659 660} 661 662 663# --- Initialize form-data -------------------------------------------------- 664sub InitForm () 665{ 666 my $cKey; 667 my $cBtn; 668 669 $oSessionGL = Session->new($pDbHdlMGL, 670 "Id" => &GetAttr("SessionId"), 671 "Length" => 16, 672 "DebugLvl" => &GetAttr("DebugLvl")) or 673 die i18n("Could not get the session-id!"); 674 675 # the Id we already have is invalid 676 # let's take the id from $oSessionGL 677 if(&GetAttr("SessionId") ne $oSessionGL->getId()) 678 { 679 680 &Redirect($oSessionGL->getId(), "WWWdb:Index"); 681 682 } 683 684 # What was the last submit-button, that triggered this page 685 foreach $cKey (keys %hFormDataMGL) 686 { 687 688 # Check the pressed Button (handle images also) 689 if ($cKey =~ /^(Btn.*?)(\.[xy])?$/) 690 { 691 printf STDERR i18n("Button %s pressed") . "<BR>\n", $1 692 if &GetAttr("DebugLvl") > 1; 693 694 $cBtn = $1; 695 &MyParamDelete($1); 696 &MyParam("WWWdbLastBtn", $1); 697 } 698 } 699 700 &MyParam("WWWdbState", "Init") 701 if !defined($hFormDataMGL{"WWWdbState"}); 702 &MyParam("WWWdbSubState", "") 703 if !defined($hFormDataMGL{"WWWdbSubState"}); 704 705# &MyParam("WWWdbLastUrlParam", &GetAttr("UrlParams")) 706# if (!defined($hFormDataMGL{"WWWdbLastUrlParam"})); 707 708 $cBgColorMGL = &MyUserVal('GUI', 'BgColor', undef); 709 $cBgImageMGL = &MyVal('GUI', 'BgImage', undef); 710 711 &setLanguage(&GetAttr("BaseDir") . "/locale", 712 &GetAttr("Lang")); 713 714} # sub InitForm 715 716 717sub setLanguage($) 718{ 719 my $cLocaleDir = shift; 720 my $cLang = shift; 721 my $cPath = "$cLocaleDir/$cLang"; 722 723 tie(%hMessagesGL, "DB_File", $cPath, O_RDONLY, 0644) || 724 die ("Cannot open language file $cPath"); 725} 726 727 728# --- Check if this application has the permission to run ------------------ 729sub HavePermissionToRun () # Db Session 730{ 731 my $cAttribs; 732 my $iObjectId = &GetObjectId(); 733 my $bInSSlMode = &UnTaint($ENV{"HTTPS"})? 1: 0; 734 my $bNeedSSl = 0; 735 my $cUseSSl = &MyVal('WWWdb', 'UseSSL', "NEVER"); 736 737 738 $cAttribs = ($oDbSessionGL->SqlSelect 739 ("SELECT 740 attribs 741 FROM 742 wwwdb_object 743 WHERE 744 id_object = ?", 745 defined $iObjectId? $iObjectId: 0))->[0]->[0]; 746 747 switch: for ($cUseSSl) 748 { 749 /^ALWAYS$/i && do { 750 751 $bNeedSSl = 1; 752 last switch; 753 }; 754 755 /^STAY$/i && do { 756 757 $bNeedSSl = ((&IsAttribOK($cAttribs, "IsSSL" => 0) != 758 &IsAttribOK($cAttribs, "IsSSL" => 1)) || 759 $bInSSlMode); 760 last switch; 761 }; 762 763 /^APP_ONLY$/i && do { 764 765 $bNeedSSl = (&IsAttribOK($cAttribs, "IsSSL" => 0) != 766 &IsAttribOK($cAttribs, "IsSSL" => 1)); 767 768 last switch; 769 }; 770 771 do { 772 773 $bNeedSSl = 0; 774 last switch; 775 }; 776 } 777 778 if($cAttribs && defined $oSessionGL) 779 { 780 if((&IsAttribOK($cAttribs, "IsAdmin" => 0) != 781 &IsAttribOK($cAttribs, "IsAdmin" => 1)) && 782 (!$oSessionGL->getState("ActualLogin"))) 783 { 784 &Error(sprintf(i18n("Please %s first!"), 785 &ResolveRefField("wwwdb://WWWdb:System:Login", 786 i18n("login")))); 787 } 788 } 789 790 if(!&IsAttribOK($cAttribs)) 791 { 792 if($cAttribs =~ "ActualLogin") 793 { 794 &Error(sprintf(i18n("Please %s first!"), 795 &ResolveRefField("wwwdb://WWWdb:System:Login", 796 i18n("login")))); 797 } 798 else 799 { 800 &Error(i18n("Sorry, you are not permitted, to run this application!")); 801 } 802 } 803 804 printf STDERR ("bNeedSSl: %d bInSSlMode: %d\n", 805 $bNeedSSl, $bInSSlMode); 806 807 # Do we have to change the encryption? 808 if($bNeedSSl != $bInSSlMode) 809 { 810 811 $ENV{"HTTPS"} = $bNeedSSl; 812 813 &Redirect(&GetAttr("SessionId"), 814 &GetAttr("ConfigFile") . ";" . 815 &GetAttr("UrlParams")); 816 } 817 818} 819 820 821 822# --- Show, what params came from last post ---------------------------------- 823sub DebugFormData() # Form CGI 824{ 825 my $cEntry; 826 827 printf STDERR (p("Form-data:"), hr({-noshade => 1, 828 -size => 1})); 829 830 foreach $cEntry (sort keys %hFormDataMGL) 831 { 832 printf STDERR "$cEntry=".&MyParam($cEntry)."<BR>\n"; 833 } 834 printf STDERR hr({-noshade => 1, 835 -size => 1}); 836 837} # sub DebugFormData 838 839 840 841# --- Now let's look, what to do -------------------------------------------- 842sub FindActionToDo() # Control 843{ 844 my $bBtnFound = 0; 845 my $cBtn; 846 my $cDefaultButton; 847 my $cEntry; 848 my $cKey; 849 my $cParamBtnName; 850 my $cSection; 851 my $oBtnPlugin; 852 853 $cBtn = &GetAttr("LastBtn"); 854 855 # look for a param in the uri 856 if(!$cBtn) 857 { 858 859 my $cUrlParams = &GetAttr("UrlParams"); 860 my @lUrlParams = split ";", $cUrlParams; 861 862 foreach (@lUrlParams) 863 { 864 my $iId = 0; 865 866 $iId = $1 867 if (/^id=([^;]+)/); 868 869 if ($iId) 870 { 871 $cBtn = "BtnSelect" . $iId; 872 # &MyParam("BtnSelect" . $iId, $iId); 873 &MyParam("WWWdbLastBtn", 874 "BtnSelect" . $iId); 875 } 876 } 877 } 878 879 # try to assign a default-button 880 unless ($cBtn) 881 { 882 my %hBtnMap = ("Init" => "BtnQry", 883 "Work" => "BtnUpd"); 884 885 if(defined $hBtnMap{&MyParam("WWWdbState")}) 886 { 887 888 printf STDERR "State:%s, Btn:%s\n", 889 &MyParam("WWWdbState"), 890 $hBtnMap{&MyParam("WWWdbState")}; 891 892 $cBtn = &MyParam("WWWdbState") 893 if (&MyVal("State ". $hBtnMap{&MyParam("WWWdbState")}, 894 &MyParam("WWWdbState")) ne "-"); 895 } 896 } 897 898 # Change the sort-order 899 if ($cBtn =~ /^BtnSort(.*)$/) 900 { 901 my $cCurrOrder = &MyParam("!Order"); 902 my $cNewOrder = $1; 903 904 if (&GetField("_ResetSort")) 905 { 906 $cCurrOrder = ""; 907 } 908 909 if ($cCurrOrder =~ m/$cNewOrder desc$/) 910 { 911 $cCurrOrder =~ s/ desc$//; 912 &MyParam("!Order", $cCurrOrder); 913 } 914 # reverse sort_order if it ends with the same field 915 elsif ($cCurrOrder =~ m/$cNewOrder$/) 916 { 917 &MyParam("!Order", $cCurrOrder . " desc"); 918 } 919 # re-arrange the sort-order 920 else 921 { 922 $cCurrOrder = "" 923 if $cCurrOrder =~ m/$cNewOrder/; 924 925 &MyParam("!Order", ($cCurrOrder? "$cCurrOrder, ": "") . $cNewOrder); 926 } 927 928 &MyParamDelete($cBtn); 929 930 $cBtn = "BtnQry"; 931 &MyParam($cBtn, "Query"); 932 &MyParam("WWWdbLastBtn", $cBtn); 933 } 934 # catch dynamic generated Buttons 935 elsif ($cBtn =~ /^BtnSelect(.+)$/) 936 { 937 my @lKeyValues = split /,/, $1; 938 my @lKeyFields = split /, /, &GetAttr("RecIdField"); 939 my $iInd; 940 941 # scan multiple primary-keys 942 for ($iInd = 0; $iInd <= $#lKeyValues; $iInd ++) 943 { 944 # Set Record-Id 945 &MyParam("Fld" . $lKeyFields[$iInd], 946 $lKeyValues[$iInd]); 947 948 } 949 950 &MyParamDelete($cBtn); 951 952 $cBtn = "BtnSelect"; 953 &MyParam($cBtn, "Select"); 954 } 955 956 $oBtnPlugin = Plugin->new("$cBtn", 957 "HasPrePost" => 1, 958 "HasMy" => 1) 959 if $cBtn; 960 961 # First look for all default-Buttons 962 foreach $cDefaultButton ("BtnNew", 963 "BtnDel", 964 "BtnQry", 965 "BtnUpd", 966 "BtnSelect", 967 "BtnCancel", 968 "BtnExit", 969 "BtnHelp", 970 "BtnOk") 971 { 972 if ($cBtn eq $cDefaultButton) 973 { 974 $bBtnFound = 1; 975 976 $oBtnPlugin->Call(); 977 Plugin->new($cBtn . "Redisplay")->Call(); 978 } 979 } 980 981 if(!$bBtnFound) 982 { 983 # Scan all sections 984 foreach $cSection ($oConfPoolGL->getSectionNames()) 985 { 986 # Scan all parameters of section 987 PARAM: 988 foreach $cParamBtnName ($oConfPoolGL->getEntryNames($cSection)) 989 { 990 991 # only interested in the Btn... = ... -Parameters 992 next 993 if ($cParamBtnName !~ /^Btn.*/); 994 995 if ($cBtn eq $cParamBtnName) 996 { 997 $bBtnFound = 1; 998 999 $oBtnPlugin->Call(); 1000 } 1001 } # foreach $cParam 1002 } # foreach $cSection 1003 } 1004 1005 if (!$bBtnFound) 1006 { 1007 # Try to start cBtn's plugin 1008 $oBtnPlugin->Call() 1009 if defined $oBtnPlugin; 1010 1011 # We are in (special) browse mode 1012 if(&MyParam("WWWdbState") eq "Qry") 1013 { 1014 &BtnQry(); 1015 } 1016 else 1017 { 1018 # Any other "unknown" mode 1019 &GenPage(); 1020 } 1021 } 1022 1023 &MyParamDelete($cBtn); 1024 1025 &SaveState(); 1026 1027} 1028 1029 1030 1031# --- Insert-Button pressed -------------------------------------------------- 1032sub BtnNew () # Trigger 1033{ 1034 &MyParam("WWWdbState", "Init"); 1035 1036 if (!&GetAttr("RecordOk")) { 1037 &GenPage(); 1038 } 1039 else { 1040 1041 &NewRecord(); 1042 } 1043 1044} 1045 1046 1047sub BtnNewRedisplay() # Trigger 1048{ 1049 if (&GetAttr("RecordOk")) 1050 { 1051 &ClearFields(); 1052 1053 # confirm insertion eventually 1054 if(!&MyUserVal("GUI", "DontConfirmAfterInsert", "")) 1055 { 1056 &OkForm("", i18n("Record inserted!")); 1057 } 1058 else 1059 { 1060 &GenPage(); 1061 } 1062 } 1063} 1064 1065 1066# --- OK-button pressed ------------------------------------------------------ 1067sub BtnOk () # Trigger 1068{ 1069 &GenPage(); 1070} 1071 1072 1073# --- Delete-button pressed -------------------------------------------------- 1074sub BtnDel () # Trigger 1075{ 1076 &MyParam("WWWdbState", "Init"); 1077 &DelRecord(); 1078} 1079 1080sub BtnDelRedisplay () # Trigger 1081{ 1082 &ClearFields(); 1083 &MyParamDelete("BtnDel"); 1084 1085 # confirm insertion eventually 1086 if(!&MyUserVal("GUI", "DontConfirmAfterDelete", "")) 1087 { 1088 &OkForm("", i18n("Record deleted!")); 1089 } 1090 else 1091 { 1092 &GenPage(); 1093 } 1094} 1095 1096 1097 1098# --- Query-button pressed --------------------------------------------------- 1099sub BtnQry () # Trigger 1100{ 1101 &MyParam("WWWdbState", "Qry"); 1102 &QryData(); 1103} 1104 1105 1106# --- Update-button pressed -------------------------------------------------- 1107sub BtnUpd () # Trigger 1108{ 1109 &MyParam("WWWdbState", "Work"); 1110 1111 if (!&GetAttr("RecordOk")) { 1112 &GenPage(); 1113 } 1114 else { 1115 1116 &UpdRecord(); 1117 &MyParam("WWWdbState", "Init"); 1118 } 1119 1120} 1121 1122sub BtnUpdRedisplay () # Trigger 1123{ 1124 if (!&GetAttr("RecordOk")) { 1125 # Update Button has to be changed to Select, as like the record 1126 # has been selected in the last cycle 1127 &MyParamDelete("BtnUpdate"); 1128 &MyParam("BtnSelect", "Select"); 1129 1130 &MyParam("WWWdbState", "Work"); 1131 1132 &GenPage(); 1133 } 1134 else 1135 { 1136 1137 &ClearFields(); 1138 1139 # eventually confirm update 1140 if(!&MyUserVal("GUI", "DontConfirmAfterUpdate", "")) 1141 { 1142 &OkForm("", "Record changed!"); 1143 } 1144 else 1145 { 1146 &GenPage(); 1147 } 1148 } 1149} 1150 1151 1152# --- This button was generated dynamically ---------------------------------- 1153sub BtnSelect () # Trigger 1154{ 1155 &MyParam("WWWdbState", "Work"); 1156 1157 &FetchRecord(); 1158} 1159 1160sub BtnSelectRedisplay () # Trigger 1161{ 1162 &GenPage(); 1163} 1164 1165 1166# --- Cancel-button pressed -------------------------------------------------- 1167sub BtnCancel () # Trigger 1168{ 1169 &MyParam("WWWdbState", "Init"); 1170} 1171 1172 1173sub BtnCancelRedisplay () # Trigger 1174{ 1175 &ClearFields(); 1176 &GenPage(); 1177} 1178 1179 1180# --- Exit-button pressed -------------------------------------------------- 1181sub BtnExit () # Trigger HTML 1182{ 1183 &Redirect(&GetAttr("SessionId"), "WWWdb:Index"); 1184} 1185 1186 1187# --- Help-button pressed ---------------------------------------------------- 1188sub BtnHelp () # Trigger HTML 1189{ 1190 &Redirect(&GetAttr("SessionId"), 1191 ("WWWdb:Tools:ShowDoc;id=,help," . 1192 lc(&GetAttr("State")) . 1193 "-mode")); 1194} 1195 1196 1197# --- closure for %hCategories 1198sub _GetCatInfo { 1199 1200 # --- Create a navigation-list in first column --------------------------- 1201 sub GetCatInfo() # HTML Nav 1202 { 1203 my $cEntry; 1204 my $cLinkKey; 1205 my $cResult; 1206 my $cUrlParams = &GetAttr("UrlParams"); 1207 my $iActualId; 1208 my $iCategory = 0; 1209 my $iInd; 1210 my $lRecord; 1211 my @lCatPath = (); 1212 my @lFields; 1213 my @lIdChain; 1214 my @lIdNames; 1215 my @lUrlParams = split ";", $cUrlParams; 1216 my $iLevel; 1217 my $iSortNr; 1218 my $iId; 1219 1220 return %hCategoriesGL 1221 if %hCategoriesGL; 1222 1223 # FIXME: Use GetObjectId 1224 return 1225 unless defined $oDbSessionGL; 1226 1227 # Generate a path upwards 1228 $cResult = ""; 1229 1230 # the url-param overloads the value of the form 1231 foreach (@lUrlParams) 1232 { 1233 1234 $iCategory = $1 1235 if (/^cat=(\d+)/); 1236 } 1237 1238 $cLinkKey = ("wwwdb://" . 1239 ($iCategory? "WWWdb:Nav": &GetAttr("ConfigFile")) . 1240 ($cUrlParams? (";" . $cUrlParams): "")); 1241 1242 # get category-info 1243 $iCategory = $oDbSessionGL->SqlSelect 1244 ("SELECT 1245 cat.id_category 1246 FROM 1247 wwwdb_category cat, 1248 wwwdb_obj_cat oc, 1249 wwwdb_object obj 1250 WHERE 1251 cat.id_category = oc.id_category AND 1252 oc.id_object = obj.id_object AND 1253 obj.ref_link = ?", 1254 $cLinkKey)->[0]->[0] 1255 unless $iCategory; 1256 1257 # we had no success ... lets try it without the url-parameters 1258 unless ($iCategory) 1259 { 1260 1261 $cLinkKey = ("wwwdb://" . 1262 &GetAttr("ConfigFile")); 1263 1264 # get category-info 1265 $iCategory = ($oDbSessionGL->SqlSelect 1266 ("SELECT 1267 cat.id_category 1268 FROM 1269 wwwdb_category cat, 1270 wwwdb_obj_cat oc, 1271 wwwdb_object obj 1272 WHERE 1273 cat.id_category = oc.id_category AND 1274 oc.id_object = obj.id_object AND 1275 obj.ref_link = ?", 1276 $cLinkKey))->[0]->[0]; 1277 } 1278 1279 push @lCatPath, $iCategory 1280 if $iCategory; 1281 1282 push @lCatPath, &MyVal('WWWdb', 'DefaultCat', 0) 1283 if &MyVal('WWWdb', 'DefaultCat', 0); 1284 1285 # this are the default-categories 1286 push @lCatPath, 10000, 1; 1287 1288 # Try the categories in the sequence <found>, default-user, default-sys 1289 foreach (@lCatPath) 1290 { 1291 1292 # get category-info 1293 $cEntry = ($oDbSessionGL->SqlSelect 1294 ("SELECT 1295 cat.id_category, 1296 cat.id_cat_of_cat, 1297 cat.name, 1298 cat.id_chain, 1299 cat.name_chain, 1300 cat.sort_nr, 1301 cat.attribs, 1302 tr1.trans_text AS name_tra, 1303 tr2.trans_text AS name_chain_tra 1304 FROM 1305 wwwdb_category cat, 1306 wwwdb_translation tr1, 1307 wwwdb_translation tr2 1308 WHERE 1309 cat.id_category = ? AND 1310 cat.name_txt_id = tr1.id_text AND 1311 cat.name_chain_txt_id = tr2.id_text AND 1312 tr1.lang = ? AND 1313 tr2.lang = tr1.lang 1314 ORDER BY 1315 cat.sort_nr", 1316 $_, 1317 &GetAttr("Lang")))->[0]; 1318 1319 if (defined $cEntry) 1320 { 1321 $iCategory = $_; 1322 last; 1323 } 1324 } 1325 1326 die sprintf i18n("No wwwdb_category record with id=%s found! " . 1327 " Please insert."), 1328 $iCategory 1329 unless defined $cEntry; 1330 1331 @lFields = @{$cEntry}; 1332 1333 @lIdChain = split /,/, $lFields[3]; 1334 @lIdNames = split /,/, ($lFields[8] eq "?" ? 1335 $lFields[4]: 1336 $lFields[8]); 1337 1338 # pop @lIdChain; 1339 # pop @lIdNames; 1340 1341 for ($iInd = 0; $iInd < (@lIdChain); $iInd++) 1342 { 1343 $hCategoriesGL{$iInd}{-999}{$lIdChain[$iInd]} = $lIdNames[$iInd]; 1344 } 1345 1346 # subcategories of this (and upper) category 1347 { 1348 # use -999 as a non-existent dummy-value when we are on top 1349 my $iParentCat = ((@lIdChain > 1)? 1350 $lIdChain[-2]: 1351 -999); 1352 1353 # read sub-categories from database 1354 $lRecord = $oDbSessionGL->SqlSelect 1355 ("SELECT 1356 ca0.id_category, 1357 ca0.name, 1358 ca0.sort_nr, 1359 ca0.attribs, 1360 tra.trans_text as tra_name, 1361 ca0.id_cat_of_cat 1362 FROM 1363 wwwdb_category ca0, 1364 wwwdb_category ca1, 1365 wwwdb_translation tra 1366 WHERE 1367 ca1.id_category = ca0.id_category AND 1368 (ca0.id_cat_of_cat = ? OR 1369 ca0.id_cat_of_cat = ?) AND 1370 (ca1.nr_of_subcats + ca0.nr_of_objs) > 0 AND 1371 ca0.name_txt_id = tra.id_text AND 1372 tra.lang = ? 1373 ORDER BY 1374 ca0.sort_nr", 1375 $iCategory, 1376 $iParentCat, 1377 &GetAttr("Lang")); 1378 1379 # generate them 1380 foreach (@$lRecord) 1381 { 1382 my $lFields; 1383 my $iDelta; 1384 1385 @lFields = @{$_}; 1386 1387 next 1388 if(!&IsAttribOK($lFields[3], 1389 "IsHidden" => 0)); 1390 1391 if($lFields[5] == $iParentCat) 1392 { 1393 1394 $iDelta = -1; 1395 } 1396 else 1397 { 1398 $iDelta = 0; 1399 } 1400 1401 $hCategoriesGL{$iInd + $iDelta}{$lFields[2]}{$lFields[0]} = 1402 ($lFields[4] eq "?" ? 1403 $lFields[1]: 1404 $lFields[4]); 1405 } 1406 } 1407 1408 foreach $iLevel (sort {$a <=> $b} keys %hCategoriesGL) 1409 { 1410 1411 foreach $iSortNr (sort {$a <=> $b} keys %{$hCategoriesGL{$iLevel}}) 1412 { 1413 1414 foreach $iId (sort {$a <=> $b} keys %{$hCategoriesGL{$iLevel}{$iSortNr}}) 1415 { 1416 print STDERR "**" x $iLevel . "$iLevel>$iSortNr>$iId iId => " . $iId . 1417 " $hCategoriesGL{$iLevel}{$iSortNr}{$iId}\n"; 1418 } 1419 1420 } 1421 } 1422 1423 return %hCategoriesGL; 1424 1425 } 1426 1427} 1428 1429 1430# --- obsolete Create a navigation-list in first column --------------------- 1431sub FirstColumn() # HTML Nav 1432{ 1433 my $cResult = ""; 1434 1435 $cResult .= &HierarchyForm(); 1436 1437 $cResult .= &SubCategoriesForm(); 1438 1439 $cResult .= &LoginForm(); 1440 1441 $cResult .= &SearchForm(); 1442 1443 $cResult .= &LangForm(); 1444 1445 return $cResult; 1446} 1447 1448 1449# --- Form for the hierarchy-information ------------------------------------ 1450sub HierarchyForm() 1451{ 1452 my %hCategories = &GetCatInfo(); 1453 my $iLevel; 1454 my $iSortNr; 1455 my $iId; 1456 my $cResult; 1457 my $iIgnoreLevel; 1458 my $iNrOfEntries =0; 1459 1460 my $oHtmlTableHier = HTML::Table->new 1461 (BorderPar => 0, 1462 CellpaddingPar => 0); 1463 1464 # find highest level of hierarchy 1465 LEVEL: 1466 foreach $iLevel (sort {$b <=> $a} keys %hCategories) 1467 { 1468 foreach $iSortNr (keys %{$hCategories{$iLevel}}) 1469 { 1470 if($iSortNr == -999) 1471 { 1472 $iIgnoreLevel = $iLevel + 1; 1473 last LEVEL; 1474 } 1475 } 1476 } 1477 1478 my @lLevel = (sort {$a <=> $b} keys %hCategories); 1479 1480 # remove last hierarchy, because it is used by SubCategoriesForm 1481 # $iIgnoreLevel = pop @lLevel; 1482 1483 foreach $iLevel (@lLevel) 1484 { 1485 foreach $iSortNr (sort {$a <=> $b} keys %{$hCategories{$iLevel}}) 1486 { 1487 1488 # Skip the hier-entries of the lowest two levels 1489 next 1490 if ((($iSortNr == -999) && 1491 ($iLevel >= $iIgnoreLevel - 1)) || 1492 ($iLevel >= $iIgnoreLevel)); 1493 1494 foreach $iId (sort {$a <=> $b} keys %{$hCategories{$iLevel}{$iSortNr}}) 1495 { 1496 print STDERR "HHH" x $iLevel . "$iLevel.$iSortNr.$iId iId => " . $iId . 1497 " $hCategories{$iLevel}{$iSortNr}{$iId}\n"; 1498 1499 $oHtmlTableHier->Element 1500 (HTML::Table::APPEND, 1501 HTML::TableRow->new()); 1502 1503 $oHtmlTableHier->Element 1504 (HTML::Table::CURRENT, $iLevel + 1, $iLevel + 1, 1505 small(b(&ResolveRefField 1506 (sprintf("wwwdb://WWWdb:Nav;cat=%s", 1507 $iId), 1508 $hCategories{$iLevel}{$iSortNr}{$iId})))); 1509 1510 $oHtmlTableHier->Element 1511 (HTML::Table::CURRENT, 1512 HTML::Table::CURRENT)->setColspanPar(99); 1513 1514 $iNrOfEntries ++; 1515 } 1516 1517 } 1518 } 1519 1520 $cResult .= &FormTempl(i18n("Hierarchy:"), 1521 $oHtmlTableHier->HtmlCode()) 1522 if $iNrOfEntries; 1523 1524 return $cResult; 1525 1526} 1527 1528 1529# --- Form for the current access-path -------------------------------------- 1530sub PathForm(;$$$) 1531{ 1532 my $cPreTextPI = shift || " ["; 1533 my $cDelimTextPI = shift || "] ["; 1534 my $cPostTextPI = shift || "] "; 1535 1536 my %hCategories = &GetCatInfo(); 1537 my $iLevel; 1538 my $iSortNr = -999; 1539 my $iId; 1540 my $cResult; 1541 1542 my @lLevel = (sort {$a <=> $b} keys %hCategories); 1543 1544 foreach $iLevel (sort {$a <=> $b} keys %hCategories) 1545 { 1546 foreach $iSortNr (keys %{$hCategories{$iLevel}}) 1547 { 1548 foreach $iId (sort {$a <=> $b} keys %{$hCategories{$iLevel}{$iSortNr}}) 1549 { 1550 $cResult .= 1551 (($cResult? $cDelimTextPI: "") . 1552 &ResolveRefField 1553 (sprintf("wwwdb://WWWdb:Nav;cat=%s", 1554 $iId), 1555 $hCategories{$iLevel}{$iSortNr}{$iId})) 1556 if $iSortNr == -999; 1557 1558 } 1559 1560 } 1561 } 1562 1563 $cResult = &ResolveRefField("wwwdb://WWWdb:Index", "WWWdb") 1564 unless $cResult; 1565 1566 return $cPreTextPI . $cResult . $cPostTextPI; 1567 1568} 1569 1570 1571# --- Form for the actual subcategories ------------------------------------- 1572sub SubCategoriesForm() 1573{ 1574 my $cBullet; 1575 my $cResult; 1576 my $iId; 1577 my $iLevel = undef; 1578 my $iMaxLevel = undef; 1579 my $iNrOfSubcats = 0; 1580 my $iSortNr; 1581 my %hCategories = &GetCatInfo(); 1582 1583 my $oHtmlTableSubCat = HTML::Table->new 1584 (BorderPar => 0, 1585 CellpaddingPar => 0); 1586 1587 # find highest level of hierarchy 1588 LEVEL: 1589 foreach $iLevel (sort {$b <=> $a} keys %hCategories) 1590 { 1591 print STDERR "CCC: iLevel = $iLevel\n"; 1592 foreach $iSortNr (keys %{$hCategories{$iLevel}}) 1593 { 1594 print STDERR "CCC: iSortNr = $iSortNr\n"; 1595 if($iSortNr == -999) 1596 { 1597 $iMaxLevel = $iLevel + 1; 1598 last LEVEL; 1599 } 1600 } 1601 } 1602 1603 print STDERR "CCC: iMaxLevel = $iMaxLevel\n"; 1604 1605 $cBullet = (&GenImage(&MyVal('Layout Table', 'Bullet1stCol', ""), 1606 "", 0) or 1607 &MyVal('Layout Table', 'Bullet1stCol', "-")); 1608 1609 foreach $iSortNr (sort {$a <=> $b} keys %{$hCategories{$iMaxLevel}}) 1610 { 1611 next 1612 if ($iSortNr == -999); 1613 1614 foreach $iId (sort {$a <=> $b} keys %{$hCategories{$iMaxLevel}{$iSortNr}}) 1615 { 1616 print STDERR "CCC" x $iMaxLevel . "$iMaxLevel.$iSortNr.$iId iId => " . $iId . 1617 " $hCategories{$iMaxLevel}{$iSortNr}{$iId}\n"; 1618 1619 $oHtmlTableSubCat->Element 1620 (HTML::Table::APPEND, 1621 HTML::TableRow->new()); 1622 1623 $oHtmlTableSubCat->Element 1624 (HTML::Table::CURRENT, $iMaxLevel, $iMaxLevel + 1, $cBullet); 1625 1626 $oHtmlTableSubCat->Element 1627 (HTML::Table::CURRENT, $iMaxLevel + 1, $iMaxLevel + 1, 1628 small(b(&ResolveRefField 1629 (sprintf("wwwdb://WWWdb:Nav;cat=%s", 1630 $iId), 1631 $hCategories{$iMaxLevel}{$iSortNr}{$iId})))); 1632 1633 $oHtmlTableSubCat->Element 1634 (HTML::Table::CURRENT, 1635 HTML::Table::CURRENT)->setColspanPar(99); 1636 1637 $iNrOfSubcats ++; 1638 } 1639 1640 } 1641 1642 $cResult .= &FormTempl(i18n("Sub-categories:"), 1643 $oHtmlTableSubCat->HtmlCode()) 1644 if $iNrOfSubcats; 1645 1646 return $cResult; 1647} 1648 1649 1650 1651# --- Form for searching the site ------------------------------------------- 1652sub SearchForm() 1653{ 1654 my $cResult = ""; 1655 my $cHeader = ""; 1656 1657 1658 $cHeader = i18n("Site-Search:"); 1659 1660 $cResult .= (textfield (-name => "Fld_Search", 1661 -maxlength => "100", 1662 -size => "10", 1663 -tabindex => 9999)); 1664 1665 $cResult .= " "; 1666 1667 $cResult .= &SubmitButton("Btn_Search", 1668 &EncodeHtml(i18n("Search"))); 1669 1670 $cResult = &FormTempl($cHeader, $cResult); 1671 1672 return $cResult; 1673} 1674 1675# --- Form for user-login -------------------------------------------------- 1676sub LoginForm() 1677{ 1678 my $cResult = ""; 1679 my $cHeader = ""; 1680 1681 if(&IsAttribOK("ActualLogin") && 1682 defined $oSessionGL && 1683 !$oSessionGL->getState("IsAnonymous")) 1684 { 1685 my $cUserName; 1686 my $cPassword; 1687 1688 ($cUserName, $cPassword) = split /,/, $oSessionGL->getState("login"); 1689 1690 $cHeader = sprintf(i18n("Logged in as %s"), 1691 b($cUserName)); 1692 1693 $cResult .= ((&ResolveRefField("wwwdb://WWWdb:System:Logout", 1694 i18n("Logout")))); 1695 } 1696 else 1697 { 1698 $cHeader = i18n("Not logged in."); 1699 $cResult .= ((&ResolveRefField("wwwdb://WWWdb:System:Login", 1700 i18n("Login")))); 1701 } 1702 1703 $cResult = &FormTempl($cHeader, center($cResult)); 1704 1705 return $cResult; 1706} 1707 1708# --- Form for language-selection ------------------------------------------- 1709sub LangForm() 1710{ 1711 my $cResult = ""; 1712 my $lLang; 1713 my $cHeader = ""; 1714 1715 $lLang = $oDbSessionGL->SqlSelect 1716 ("SELECT 1717 key_value, label, sort_nr 1718 FROM 1719 wwwdb_lookup 1720 WHERE 1721 lang = 'en' AND 1722 key_name = 'lang_select' 1723 ORDER BY 1724 sort_nr"); 1725 1726 # Select the language 1727 if (@$lLang > 1) 1728 { 1729 my $cLang; 1730 my %hLabels = (); 1731 my @lListValues = (); 1732 1733 $cHeader = i18n("Language-Select:"); 1734 1735 1736 # Split the Value,Label list in two Arrays 1737 foreach $cLang (@$lLang) 1738 { 1739 push @lListValues, $cLang->[0]; 1740 $hLabels{$cLang->[0]} = $cLang->[1]; 1741 } 1742 1743 $cResult .= (scrolling_list(-name => "Fld_SelLang", 1744 -values => \@lListValues, 1745 -labels => \%hLabels, 1746 -default => &GetAttr("Lang"), 1747 -override => 1, 1748 -size => "1")); 1749 1750 $cResult .= &SubmitButton("Btn_SelLang", 1751 &EncodeHtml("<<")); 1752 1753 1754 } 1755 1756 $cResult = &FormTempl($cHeader, center($cResult)); 1757 1758 return $cResult; 1759} 1760 1761 1762 1763# --- Generate a HTML-Container for some Data ------------------------------- 1764sub FormTempl($$) 1765{ 1766 my $cHeaderPI = shift; 1767 my $cContentPI = shift; 1768 my $cResult = ""; 1769 1770 if($cContentPI) 1771 { 1772 my $oTemplate = HTML::Template->new 1773 (filename => (&GetAttr("BaseDir") . 1774 &MyVal('WWWdb', "NavTemplate", 1775 "/lib/WWWdb/Templ/Tmpl_WWWdbNav.html")), 1776 die_on_bad_params => 0); 1777 1778 1779 # fill in some parameters 1780 $oTemplate->param(HEADER => $cHeaderPI, 1781 CONTENT => $cContentPI); 1782 1783 $cResult = $oTemplate->output; 1784 } 1785} 1786 1787 1788 1789 1790=head2 ClearFields - clear all entry-fields 1791 1792=over 2 1793 1794=item B<DESCRIPTION> 1795 1796Clears all entry-fields in the Form which were defined via 1797[Layout\ Field\ ...] entries. 1798 1799=item B<SYNOPSIS> 1800 1801ClearField(); 1802 1803=item B<RETURN VALUE> 1804 1805None. 1806 1807=item B<EXAMPLE> 1808 1809 # Clear all fields to blank 1810 &ClearFields(); 1811 1812=item B<SEE ALSO> 1813 1814SetField 1815 1816=back 1817 1818=cut 1819 1820# --- Clear all user Fields -------------------------------------------------- 1821sub ClearFields() # CGI Form 1822{ 1823 my $cEntry; 1824 1825 foreach $cEntry (keys %hFormDataMGL) 1826 { 1827 if ($cEntry =~ /^Fld(.*)$/) 1828 { 1829 &MyParamDelete($cEntry); 1830 &MyParamDelete($1); 1831 } 1832 } 1833} 1834 1835# --- generate a error-message ------------------------------------------------ 1836sub DbiErrorAndExit ($) # Db HTML 1837{ 1838 1839 my $cSqlOperationPI = shift; 1840 1841 printf STDERR $pDataSetMGL->LastSQLStatement() . "<BR>\n" 1842 if &GetAttr("DebugLvl") > 3; 1843 1844 if( $pDataSetMGL->DBHdl()->err) 1845 { 1846 &Error(sprintf(i18n("Database Error occured during %s!") . "<BR>" . 1847 i18n(" SQL-Error: (%d) %s") . "<BR>" . 1848 i18n(" Statement: %s") . "<BR>", 1849 $cSqlOperationPI, 1850 $pDataSetMGL->DBHdl()->err, 1851 $pDataSetMGL->DBHdl()->errstr, 1852 $pDataSetMGL->LastSQLStatement())); 1853 } 1854} 1855 1856 1857# --- Query-data and display the result -------------------------------------- 1858sub QryData() # (HTML Db Recordset ConfigFile CGI Plugin) 1859{ 1860 my $bSortKeys = 0; 1861 my $cBgColor2; 1862 my $cBgColor; 1863 my $cField; 1864 my $cKey; 1865 my $cLastRecId; 1866 my $cName; 1867 my $cNavBtnsOrMsg; 1868 my $cOp; 1869 my $cQrySelType; 1870 my $cRecIdFields; 1871 my $cValue; 1872 my $iInd; 1873 my $iNrOfColouredLine; 1874 my $iNrOfRows; 1875 my $oHtmlTableApp; 1876 my $oTableHeaderPlugin; 1877 my $pRecord; 1878 my @lNames; 1879 my %hOPlugins; 1880 1881 $cBgColor2 = &MyVal('Qry', 'BgColor2', "#dddddd"); 1882 $iNrOfColouredLine = &MyVal('Qry', 'NrOfColLine', 2); 1883 $cQrySelType = &MyVal('Qry', 'SelType', 'Btn'); 1884 1885 $cRecIdFields = &GetAttr("RecIdField"); 1886 1887 $oTableHeaderPlugin = Plugin->new("TableHeader", 1888 "HasPrePost" => 1, 1889 "HasMy" => 1); 1890 1891 $oHtmlTableApp = HTML::Table->new 1892 (BorderPar => &MyVal('Qry', 'BorderWidth', '0'), 1893 BgColorPar => &MyUserVal('Layout Table', 1894 'BgColor', 1895 $cBgColorMGL), 1896 CellpaddingPar => 0, 1897 WidthPar => "100%", 1898 HeightPar => "100%"); 1899 1900 # add id-field to the query 1901 &MyParam("!Fields", 1902 ((&MyVal('Qry', 'Distinct')? "DISTINCT ": "") . 1903 &MyVal('Data', 'QryFields') . 1904 ", ". 1905 $cRecIdFields )); 1906 1907 &InitDBIxRecordset(); 1908 1909 # Here the User can manipulate form-data 1910 Plugin->new("PreCreateForm")->Call(); 1911 1912 &DebugFormData(); 1913 1914 # create recordset 1915 *pDataSetMGL = DBIx::Recordset->Setup(\%hFormDataMGL); 1916 1917 # Get the type-info for the fields 1918 &GetAllFieldInfo(&MyVal('Data', 'Table'), $pDataSetMGL); 1919 1920 # construct selection-criteria 1921 foreach $cKey (keys %hFormDataMGL) 1922 { 1923 1924 if ($cKey =~ "^Fld.*" and &MyParam($cKey) ne "") 1925 { 1926 1927 # get the fieldname 1928 ($cField = $cKey) =~ s/^Fld//; 1929 1930 # we got an operator 1931 if(&MyParam("\*$cField")) 1932 { 1933 &MyParam($cKey, 1934 &MyParam("\*$cField") . " " . 1935 &MyParam("$cField")); 1936 1937 } 1938 1939 # now scan the search-operator 1940 if(&MyParam($cKey) =~ /^(<>|>=|<=|<|>|!=|=|like)\s*(.*)$/) 1941 { 1942 ($cOp, $cValue) = ($1, $2); 1943 } 1944 else # no search-operator 1945 { 1946 # * is replaced with LIKE 1947 if (&MyParam($cKey) =~ /\*/) 1948 { 1949 ($cValue = &MyParam($cKey)) =~ s/\*/%/g; 1950 $cOp = "like"; 1951 1952 } 1953 else 1954 { 1955 $cOp = "="; 1956 $cValue = &MyParam($cKey); 1957 } 1958 } 1959 1960 # make this field ready for querying the database 1961 &MyParam($cKey, $cValue); 1962 1963 &ConvertDataForDb("Form2Db", $cField); 1964 $cValue = &MyParam($cKey); 1965 1966 if($cValue) 1967 { 1968 # if an empty-value is detected use " " 1969 if (($cValue eq "''") or 1970 ($cValue eq '""')) 1971 { 1972 $cValue = ""; 1973 } 1974 1975 &MyParam("\*$cField", $cOp); 1976 &MyParam("$cField", $cValue); 1977 1978 printf STDERR sprintf(i18n("%s => Op: s(%s) Value: s(%s)") . 1979 "<BR>\n", 1980 $cField, 1981 $cOp, 1982 $cValue) 1983 if &GetAttr("DebugLvl") > 3; 1984 } 1985 } # if ($cKey =~ "Fld.*" and &MyParam($cKey) ne "") 1986 } # foreach $cKey (keys %hFormDataMGL) 1987 1988 &InitDBIxRecordset(); 1989 1990 # Search for Data 1991 $pDataSetMGL->Search(\%hFormDataMGL); 1992 1993 # catch DB-error 1994 &DbiErrorAndExit(i18n("data-querying")); 1995 1996 { 1997 my $cEntry; 1998 my $iRowInd = 0; 1999 2000 # show table-header like in field-list 2001 foreach $cEntry (split /, */, 2002 "_link, " . &MyVal('Data', 'QryFields')) 2003 { 2004 my $cConfKey = "Layout Qry $cEntry"; 2005 2006 $hOPlugins{$cEntry} = 2007 Plugin->new("QryConv_${cEntry}"); 2008 2009 if (lc($cEntry) eq "_link") 2010 { 2011 2012 if ($cQrySelType ne "None") 2013 { 2014 2015 $oHtmlTableApp->Element 2016 (0, $iRowInd, 0, 2017 p(font({-SIZE=>2}, 2018 checkbox(-name => "Fld_ResetSort", 2019 -checked => 0, 2020 -value => 1, 2021 -override => 1, 2022 -label => " " . i18n("Reset")))). 2023 &MyVal($cConfKey, "Text")); 2024 } 2025 } 2026 else 2027 { 2028 my $cBtnLabel = &MyVal($cConfKey, "Text", $cEntry); 2029 2030 if(!$cBtnLabel) 2031 { 2032 $oHtmlTableApp->Element 2033 (0, $iRowInd, 0, " "); 2034 } 2035 else 2036 { 2037 2038 $oHtmlTableApp->Element 2039 (0, $iRowInd, 0, 2040 p(font({-SIZE=>2}, 2041 &SubmitButton("BtnSort$cEntry", 2042 $cBtnLabel)))); 2043 $bSortKeys = 1; 2044 } 2045 } 2046 $iRowInd ++; 2047 } 2048 2049 } 2050 2051 $oHtmlTableApp->Element(0, 0, 0, &MyVal("Layout Qry _link", "Text")) 2052 unless $bSortKeys; 2053 2054 $iInd = 0; 2055 while ($pRecord = $pDataSetMGL[$iInd]) 2056 { 2057 $iInd ++; 2058 2059 my $iRow = 0; 2060 # Show different colors for the different rows 2061 $cBgColor = ((($iInd - 1) % $iNrOfColouredLine)? 2062 $cBgColorMGL: 2063 "$cBgColor2"); 2064 2065 foreach $cName (split /, */, 2066 "_link, " . &MyVal('Data', 'QryFields')) 2067 { 2068 my $cConfKey = "Layout Qry $cName"; 2069 my %hAttribs = (); 2070 my $cTabEntry; 2071 2072 # $cName = lc($cName); 2073 2074 $hAttribs{"BgColorPar"} = $cBgColor 2075 if $cBgColor; 2076 2077 # we need this field for generating a selector for the record 2078 if ($cName eq "_link") 2079 { 2080 my @lKeyFields = split /, /, &GetAttr("RecIdField"); 2081 2082 # scan multiple primary-keys 2083 foreach (@lKeyFields) 2084 { 2085 $_ = $$pRecord{$_}; 2086 } 2087 2088 $cLastRecId = join ",", @lKeyFields; 2089 $cLastRecId =~ s/ /%20/g; 2090 $cLastRecId =~ s/://g; # Normally 3A but this works no 2091 $cLastRecId =~ s/\//%2F/g; 2092 2093 if($cQrySelType eq "Check") 2094 { 2095 2096 $cTabEntry = 2097 font({-SIZE=>2}, 2098 checkbox(-name => "Chb" . $$pRecord{$cName}, 2099 -checked => $$pRecord{$cName}, 2100 -value => i18n(&MyVal($cConfKey, 2101 "Value", 2102 "1")), 2103 -label => &EncodeHtml(i18n($iInd)))); 2104 2105 } 2106 elsif($cQrySelType eq "Link") 2107 { 2108 $cTabEntry = &GenField("Qry", 2109 "_link", 2110 ("wwwdb://" . 2111 &GetAttr("ConfigFile") . 2112 ";id=" . 2113 $cLastRecId)); 2114 } 2115 elsif($cQrySelType eq "None") 2116 { 2117 $cTabEntry = ""; 2118 next; 2119 } 2120 else 2121 { 2122 $cTabEntry = 2123 font({-SIZE=>2}, 2124 &SubmitButton("BtnSelect" . $cLastRecId, 2125 &EncodeHtml(i18n($iInd)))); 2126 } 2127 } 2128 # not the selector 2129 else 2130 { 2131 my $cValue; 2132 2133 # use the default-plugin, if available. If not take 2134 # simply the field-value 2135 $cValue = ($hOPlugins{$cName}->IsDefined("Default")? 2136 $hOPlugins{$cName}->Call($$pRecord{$cName}, 2137 %{$pRecord}): 2138 $$pRecord{$cName}); 2139 2140 $hAttribs{"AlignPar"} = &MyVal($cConfKey, "Align", "") 2141 if &MyVal($cConfKey, "Align", ""); 2142 $hAttribs{"ValignPar"} = &MyVal($cConfKey, "VAlign", "") 2143 if &MyVal($cConfKey, "VAlign", ""); 2144 $hAttribs{"NowrapPar"} = "NOWRAP" 2145 if &MyVal($cConfKey, "NoWrap", ""); 2146 $hAttribs{"BorderPar"} = &MyVal('Layout Table', 'Border', '0') 2147 if &MyVal('Layout Table', 'Border', '0'); 2148 2149 if($cValue) 2150 { 2151 2152 $cTabEntry = &GenField("Qry", 2153 $cName, 2154 ($cValue . 2155 "\\," . 2156 $$pRecord{&GetAttr("RecIdField")})); 2157 2158 # FIXME: Check why we need ... $$pRecord{&GetAttr("RecIdField") 2159 } 2160 else 2161 { 2162 2163 $cTabEntry = " " 2164 if !$cTabEntry; 2165 } 2166 } 2167 2168 $oHtmlTableApp->Element 2169 ($iInd, $iRow, HTML::TableCol->new(%hAttribs)); 2170 2171 $oHtmlTableApp->Element 2172 ($iInd, $iRow, 0, $cTabEntry); 2173 2174 $iRow ++; 2175 } 2176 } # while ($pRecord = $pDataSetMGL[$iInd++]) 2177 2178 $iNrOfRows = $iInd; 2179 2180 # bottom area 2181 { 2182 $iInd ++; 2183 2184 # No record was found 2185 if ($iNrOfRows == 0) 2186 { 2187 2188 # "remove" sort-buttons 2189 foreach (0 .. $oHtmlTableApp->getMaxCol()) 2190 { 2191 $oHtmlTableApp->Element(0, $_, 0, ""); 2192 } 2193 2194 # Message, that no data was found 2195 $cNavBtnsOrMsg = Plugin->new("NoRecordFound", 2196 "HasMy" => 1)->Call(); 2197 } 2198 # exactly one record found, show directly 2199 elsif ($iNrOfRows == 1 && !&MyVal('Qry', 'ForceBrowse', )) 2200 { 2201 # Throw away the generated form 2202 $oHtmlTableApp = undef; 2203 2204 # "emulate" the Select-Button 2205 &Redirect(&GetAttr("SessionId"), 2206 &GetAttr("ConfigFile") . ";id=$cLastRecId"); 2207 } 2208 else 2209 { 2210 # due to security-reasons thes fields are deleted 2211 foreach $cKey ("!DataSource", "!Database", "!Username", "!Password") 2212 { 2213 &MyParamDelete($cKey); 2214 } 2215 2216 # Remove all unneccessary hidden-fields 2217 foreach $cKey (sort keys %hFormDataMGL) 2218 { 2219 if (($cKey =~ /^Btn.*/) || 2220 ($cKey =~ /^Fld_.*/) || 2221 ($cKey =~ /^_.*/)) 2222 { 2223 &MyParamDelete($cKey); 2224 } 2225 2226 } 2227 2228 # all hidden fields will be generated here too 2229 $cNavBtnsOrMsg = $pDataSetMGL->PrevNextForm 2230 ({-first => i18n('|< Begin'), 2231 -prev => i18n('<< Back'), 2232 -next => i18n('Forward >>'), 2233 -last => i18n('End >|')}, 2234 \%hFormDataMGL); 2235 2236 2237 } 2238 2239 # WORKAROUND: extract form-commands from $cNavBtnsOrMsg 2240 $cNavBtnsOrMsg =~ s/<\/?form.*?>//gi; 2241 2242 $oHtmlTableApp->Element($iInd, 0, 0, center($cNavBtnsOrMsg)); 2243 $oHtmlTableApp->Element 2244 ($iInd, 0)->setColspanPar($oHtmlTableApp->getMaxCol()); 2245 2246 $iInd ++; 2247 $oHtmlTableApp->Element($iInd, 0, 0, &FormButtons()); 2248 $oHtmlTableApp->Element 2249 ($iInd, 0)->setColspanPar($oHtmlTableApp->getMaxCol()); 2250 2251 } 2252 2253 &GenHtmlForm($oTableHeaderPlugin->Call(&MyParam("!Order")? 2254 (i18n("Search-result ordered by ") . 2255 i18n(&MyParam("!Order"))): 2256 i18n("Search-result")), 2257 $oHtmlTableApp->HtmlCode(), 2258 undef); 2259} # sub QryData 2260 2261# -- Plugin, if no record was found ----------------------------------- 2262sub NoRecordFound() 2263{ 2264 my $cResult = 2265 (br() x 2 . 2266 p(b(small(i18n("Sorry! No data is available " . 2267 "for your search-criteria!")))) . 2268 br() x 2); 2269 2270 return $cResult; 2271} 2272 2273sub FormButtons() # HTML (ConfigFile) 2274{ 2275 my $cParam; 2276 2277 my $cResult = ""; 2278 2279 $cResult .= ("<CENTER>\n"); 2280 2281 # Work with selected Record 2282 if (&MyParam("WWWdbState") eq "Work") { 2283 2284 $cResult .= &AddSubmitButton("Work", "BtnUpd", i18n("Update.png")); 2285 $cResult .= &AddSubmitButton("Work", "BtnDel", i18n("Delete.png")); 2286 2287 $cResult .= &UserButtonsOfState("Work", ("BtnUpd", "BtnDel")); 2288 } 2289 # Initial state 2290 elsif(&MyParam("WWWdbState") eq "Init") { 2291 2292 $cResult .= &AddSubmitButton("Init", "BtnQry", i18n("Query.png")); 2293 $cResult .= &AddSubmitButton("Init", "BtnNew", i18n("Insert.png")); 2294 2295 $cResult .= &UserButtonsOfState("Init", ("BtnQry", "BtnNew")); 2296 2297 } 2298 # Query-mode 2299 elsif(&MyParam("WWWdbState") eq "Qry") { 2300 2301 $cResult .= &UserButtonsOfState("Qry", ()); 2302 } 2303 2304 # Buttons, that appear in every state 2305 2306 $cResult .= &AddSubmitButton("All", "BtnCancel", i18n("Cancel.png")); 2307 $cResult .= &AddSubmitButton("All", "BtnExit", i18n("Exit.png")); 2308 $cResult .= &AddSubmitButton("All", "BtnHelp", i18n("Help.png")); 2309 2310 $cResult .= &UserButtonsOfState("All", ("BtnCancel", "BtnExit", "BtnHelp")); 2311 2312 $cResult .= ("</CENTER>\n"); 2313 2314 return $cResult; 2315} 2316 2317# --- scan the config-file for user-defined buttons in this state ------------ 2318sub UserButtonsOfState ($\@) # CGI Html 2319{ 2320 my $cStatePI = shift; 2321 my @lcDefaultButtonsPI = @_; 2322 2323 my $cParamBtnName; 2324 my $cDefaultButton; 2325 my $cSection; 2326 my $cResult = ""; 2327 2328 # Scan all sections 2329 foreach $cSection ($oConfPoolGL->getSectionNames()) 2330 { 2331 2332 # only the [State ...] sections are interesting 2333 if($cSection eq "State $cStatePI") 2334 { 2335 # Scan all parameters of section 2336 PARAM: 2337 foreach $cParamBtnName ($oConfPoolGL->getEntryNames($cSection)) 2338 { 2339 2340 # only the Btn... = ... -Parameters are interesting 2341 next 2342 if ($cParamBtnName !~ /^Btn.*/); 2343 2344 # Default-Buttons are handled explicitly 2345 foreach $cDefaultButton (@lcDefaultButtonsPI) 2346 { 2347 next PARAM 2348 if($cParamBtnName eq $cDefaultButton); 2349 2350 } # foreach $cDefaultButton 2351 2352 $cResult .= &AddSubmitButton("$cStatePI", "$cParamBtnName"); 2353 2354 } # foreach $cParam 2355 } # if($cSection eq "State $cStatePI" 2356 } # foreach $cSection 2357 2358 return $cResult; 2359} 2360 2361 2362# --- add a single Button if allowed in config-file 2363sub AddSubmitButton () # HTML 2364{ 2365 my ($cStatePI, $cBtnNamePI, $cDefaultPI) = @_; 2366 2367 my $cBtnLabel; 2368 my $cResult = ""; 2369 2370 2371 $cBtnLabel = &MyVal("State $cStatePI", "$cBtnNamePI"); 2372 2373 # show button only, if label is ne "-" 2374 if ("$cBtnLabel" ne "-") 2375 { 2376 $cBtnLabel = $cDefaultPI 2377 if (!$cBtnLabel); 2378 2379 $cResult .= &SubmitButton($cBtnNamePI, $cBtnLabel); 2380 } 2381 2382 return $cResult; 2383 2384} 2385 2386 2387sub SubmitButton($$) 2388{ 2389 my ($cBtnNamePI, $cLabelPI) = @_; 2390 2391 my $cFilename = ""; 2392 my $cResult; 2393 my $cLabel = i18n($cLabelPI); 2394 2395 if($cLabelPI =~ /(.*)\.(png|jpg|gif)/) 2396 { 2397 $cFilename = (&GetAttr("BaseDir") . 2398 "/lib/Images/Btn" . 2399 i18n($cLabelPI)); 2400 2401 if (! -f $cFilename) 2402 { 2403 $cFilename = undef; 2404 $cLabel = $1; 2405 2406 } 2407 else 2408 { 2409 $cFilename = ("/" . 2410 &GetAttr("ScriptName") . 2411 "/lib/Images/Btn" . 2412 i18n($cLabelPI)); 2413 2414 } 2415 } 2416 2417 if ($cFilename) 2418 { 2419 $cResult = image_button(-name => $cBtnNamePI, 2420 -src => $cFilename, 2421 -border => "0"); 2422 } 2423 else 2424 { 2425 $cResult = submit(-name => $cBtnNamePI, 2426 -label => i18n($cLabel)). ""; 2427 2428 } 2429 2430 return $cResult; 2431 2432} 2433 2434 2435 2436# --- Check the whole record ------------------------------------------------- 2437sub CheckRecord () # (DataRecord Plugin ConfigFile) 2438{ 2439 2440 my $cField; 2441 my $cTable; 2442 my @lFields = (); 2443 2444 # empty the error-hash 2445 undef %hFieldErrorsMGL; 2446 2447 my $oPluginEveryField = 2448 Plugin->new("Check_${cTable}_EveryField"); 2449 2450 $cTable = &MyVal('Data', 'Table'); 2451 2452 push @lFields, split ", ", &MyVal('Data', 'IdField'); 2453 push @lFields, split ", ", &MyVal('Data', 'UpdFields'); 2454 push @lFields, split ", ", &MyVal('Data', 'ExtraFields'); 2455 2456 foreach $cField (@lFields) 2457 { 2458 &InternalFieldCheck($cField); 2459 2460 $oPluginEveryField->Call("$cField"); 2461 2462 Plugin->new("Check_${cTable}_${cField}")->Call(); 2463 2464 } 2465 2466 Plugin->new("Check_$cTable")->Call(); 2467 2468 return; 2469 2470} # sub CheckRecord 2471 2472 2473 2474 2475=head2 InternalFieldCheck - make default-checks 2476 2477=over 2 2478 2479=item B<DESCRIPTION> 2480 2481FIXME: add dcos 2482 2483=item B<SYNOPSIS> 2484 2485=item B<RETURN VALUE> 2486 2487None. 2488 2489=item B<EXAMPLE> 2490 2491 # The Record has not been found 2492 &OkForm("error", "Sorry, but the record couldn't be found!"); 2493 2494=item B<SEE ALSO> 2495 2496Error 2497 2498=back 2499 2500=cut 2501 2502# --- make internal checks --------------------------------------------------- 2503sub InternalFieldCheck($) # HTML 2504{ 2505 my $cFieldNamePI = shift; 2506 2507 my $cPattern; 2508 my $cValue = &GetField($cFieldNamePI); 2509 2510 # make lowercase 2511 if (&MyVal("Layout Field $cFieldNamePI", 'ToLower')) 2512 { 2513 &SetField($cFieldNamePI, 2514 lc($cValue)); 2515 } 2516 2517 # make uppercase 2518 if (&MyVal("Layout Field $cFieldNamePI", 'ToUpper')) 2519 { 2520 &SetField($cFieldNamePI, 2521 uc($cValue)); 2522 } 2523 2524 # check the Mandatory-Flag 2525 if (&MyVal("Layout Field $cFieldNamePI", 'Mandatory')) 2526 { 2527 &AddError("$cFieldNamePI", 2528 sprintf(i18n("No value for field %s, please complete!"), 2529 (i18n($cFieldNamePI)))) 2530 if(!$cValue); 2531 } 2532 2533 $cPattern = &MyVal("Layout Field $cFieldNamePI", 'MustMatch'); 2534 2535 # check the MustMatch-Flag 2536 if ($cPattern && ($cValue ne "")) 2537 { 2538 2539 printf STDERR "MATCHING: '$cPattern' with '$cValue'\n"; 2540 2541 if($cValue !~ /$cPattern/) 2542 { 2543 my $cErrMessage; 2544 2545 $cErrMessage = (i18n($cFieldNamePI) . 2546 ": " . 2547 &MyVal("Layout Field $cFieldNamePI", 2548 'MustMatch_Errmsg', 2549 i18n("didn't meet the " . 2550 "right format, please correct!"))); 2551 2552 &AddError("$cFieldNamePI", $cErrMessage); 2553 } 2554 } 2555 2556} 2557 2558 2559# --- convert data between html-form and a format, the database can understand 2560sub ConvertDataForDb($;$) # Db (Plugin) 2561{ 2562 my $cDirectionPI = shift; 2563 my $cFieldPI = shift; 2564 2565 my $cField; 2566 my $cTable; 2567 my @lFields; 2568 my %hConvPlugins = (); 2569 2570 if (defined($cFieldPI)) 2571 { 2572 @lFields = $cFieldPI; 2573 } 2574 else 2575 { 2576 push @lFields, split ", ", &MyVal('Data', 'IdField'); 2577 push @lFields, split ", ", &MyVal('Data', 'UpdFields'); 2578 push @lFields, split ", ", &MyVal('Data', 'ExtraFields'); 2579 } 2580 2581 print STDERR "ConvertDataForDb Fields: @lFields\n" 2582 if &GetAttr("DebugLvl") > 3; 2583 2584 $cTable = &MyVal('Data', 'Table'); 2585 2586 foreach $cField (@lFields) 2587 { 2588 my $cFieldType; 2589 my $cFunctName; 2590 my $cEvalCode; 2591 my $cFieldValue; 2592 my $cResult = undef; 2593 2594 $cFieldType = &GetFieldTypeName($cField); 2595 2596 # assert($cFieldType) if DEBUG 2597 $cFunctName = sprintf("DbSession::%s_%s", 2598 $cFieldType, 2599 $cDirectionPI); 2600 2601 $cFieldValue = &GetField($cField); 2602 2603 if(!defined $hConvPlugins{"$cFunctName"}) 2604 { 2605 $hConvPlugins{"$cFunctName"} = eval "defined(&$cFunctName)" || 0; 2606 printf STDERR ("defined $cFunctName = %s\n", 2607 $hConvPlugins{"$cFunctName"}); 2608 } 2609 2610 $cEvalCode = "$oDbTargetGL->$cFunctName(" . $oDbTargetGL . ", $cFieldValue)"; 2611 $cResult = ($hConvPlugins{"$cFunctName"}? 2612 eval {$oDbTargetGL->$cFunctName($cFieldValue);}: 2613 $cFieldValue); 2614 2615 if (defined $cResult) 2616 { 2617 print STDERR "Field: $cFunctName(), $cField, $cFieldValue -> $cResult\n" 2618 if &GetAttr("DebugLvl") > 2; 2619 2620 # this happens, when no plugin is defined, or the first param 2621 # is not correctly shifted 2622 # *** This may be a dirty Hack - better solutions are welcome *** 2623 $cResult =~ s/DbSession=HASH(.*) //; 2624 2625 &SetField($cField, $cResult); 2626 } 2627 } 2628 2629 return; 2630} 2631 2632 2633 2634# --- get the values of the fields and store them as HTML-parameters --------- 2635sub ExtractFieldsFromRecordset() # HTML CGI Recordset 2636{ 2637 2638 my $cKey; 2639 my $cField; 2640 2641 foreach $cKey (keys %hFormDataMGL) 2642 { 2643 2644 if ($cKey =~ /^Fld(.*)/ ) 2645 { 2646 2647 # get fieldname 2648 $cField = $1; 2649 &MyParam($cKey, &MyParam($cField)) 2650 if $cField; 2651 2652 } # ($cKey =~ /^Fld(.*)/ 2653 } # foreach $cKey (keys %hFormDataMGL) 2654 2655} 2656 2657 2658# --- get the HTML-parameters and store them as fields for te recordset ------ 2659sub CreateFieldsForRecordset() # HTML CGI Recordset 2660{ 2661 2662 my $cKey; 2663 my $cField; 2664 2665 foreach $cKey (keys %hFormDataMGL) 2666 { 2667 2668 if ($cKey =~ "^Fld(.*)") 2669 { 2670 2671 # get fieldnames 2672 $cField = $1; 2673 &MyParam("$cField", (&MyParam($cKey)? 2674 &MyParam($cKey): 2675 "")); 2676 2677 } # if ($cKey =~ "Fld.*" and &MyParam($cKey) ne "") { 2678 } # foreach $cKey (keys %hFormDataMGL) 2679 2680} 2681 2682 2683# --- insert a new record ---------------------------------------------------- 2684sub NewRecord() # Db 2685{ 2686 &InitDBIxRecordset(); 2687 2688 # create recordset 2689 *pDataSetMGL = DBIx::Recordset->Setup(\%hFormDataMGL); 2690 2691 # Get the type-info for the fields 2692 &GetAllFieldInfo(&MyVal('Data', 'Table'), $pDataSetMGL); 2693 2694 &ConvertDataForDb("Form2Db"); 2695 2696 # Insert Record here 2697 &CreateFieldsForRecordset(); 2698 2699 $pDataSetMGL->Insert(\%hFormDataMGL); 2700 2701 # catch DB-error 2702 &DbiErrorAndExit(i18n("record-insertion")); 2703 2704} 2705 2706 2707# --- delete record ------------------------------------------------------- 2708sub DelRecord() # Db 2709{ 2710 my @lKeyFields = split /, /, &GetAttr("RecIdField"); 2711 my %hKeysForDelete = (); 2712 2713 &CreateFieldsForRecordset(); 2714 2715 # here something went wrong 2716 if (!&GetAttr("RecId")) 2717 { 2718 die(i18n("internal error -> Record-ID missing!!")); 2719 } 2720 2721 &InitDBIxRecordset(); 2722 2723 # scan multiple primary-keys 2724 foreach (@lKeyFields) 2725 { 2726 $hKeysForDelete{$_} = &GetField($_); 2727 } 2728 2729 # create Recordset 2730 *pDataSetMGL = DBIx::Recordset->Setup(\%hFormDataMGL); 2731 2732 $pDataSetMGL->Delete(\%hKeysForDelete); 2733 2734 # catch DB-error 2735 &DbiErrorAndExit(i18n("record-deletion")); 2736 2737 2738} 2739 2740 2741 2742 2743# --- update a record ------------------------------------------------------ 2744sub UpdRecord() # Db 2745{ 2746 my @lKeyFields = split /, /, &GetAttr("RecIdField"); 2747 my %hKeysForUpdate = (); 2748 2749 # scan multiple primary-keys 2750 foreach (@lKeyFields) 2751 { 2752 $hKeysForUpdate{$_} = &GetField($_); 2753 } 2754 2755 &InitDBIxRecordset(); 2756 2757 # create recordset 2758 *pDataSetMGL = DBIx::Recordset->Setup(\%hFormDataMGL); 2759 2760 # Get the type-info for the fields 2761 &GetAllFieldInfo(&MyVal('Data', 'Table'), $pDataSetMGL); 2762 2763 &ConvertDataForDb("Form2Db"); 2764 2765 # here something went wrong 2766 if (!&GetAttr("RecId")) 2767 { 2768 die(i18n("internal error -> Record-ID missing!!")); 2769 } 2770 2771 # Update Recordset here 2772 &CreateFieldsForRecordset(); 2773 2774 $pDataSetMGL->Update 2775 (\%hFormDataMGL, 2776 \%hKeysForUpdate); 2777 2778 # catch DB-error 2779 &DbiErrorAndExit(i18n("record-update")); 2780 2781 2782} 2783 2784 2785 2786 2787# --- read one single record------------------------------------------------ 2788sub FetchRecord() # Db CGI 2789{ 2790 2791 my $pRecord; 2792 my $plNames; 2793 my $cName; 2794 my @lKeyFields = split /, /, &GetAttr("RecIdField"); 2795 my %hKeysForSelect = (); 2796 2797 # something went wrong 2798 if (!&GetAttr("RecId")) 2799 { 2800 die(i18n("internal error -> Record-ID missing!!")); 2801 &MyExit(); 2802 } 2803 2804 # get all fields for the selection 2805 &MyParam("!Fields", (&GetAttr("RecIdField") . ", " .&MyVal('Data', 'UpdFields'))); 2806 2807 # scan multiple primary-keys 2808 foreach (@lKeyFields) 2809 { 2810 $hKeysForSelect{$_} = &GetField($_); 2811 } 2812 2813 &InitDBIxRecordset(); 2814 2815 # create recordset 2816 *pDataSetMGL = DBIx::Recordset->Setup(\%hFormDataMGL); 2817 2818 # Record-Id=Value 2819 $pDataSetMGL->Select(\%hKeysForSelect); 2820 2821 # catch DB-error 2822 &DbiErrorAndExit(i18n("record-re-select")); 2823 2824 # Get the type-info for the fields 2825 &GetAllFieldInfo(&MyVal('Data', 'Table'), $pDataSetMGL); 2826 2827 2828 $plNames = $pDataSetMGL->Names; 2829 $pRecord = $pDataSetMGL[0]; 2830 2831 # distribute the found fields in HTML-form 2832 foreach $cName (@$plNames) 2833 { 2834 # &MyParam("Fld" . lc($cName), $$pRecord{lc($cName)}); 2835 &MyParam("Fld" . $cName, $$pRecord{$cName}); 2836 } 2837 2838 # make data ready for interaction with user 2839 &ConvertDataForDb("Db2Form"); 2840 2841 2842} # sub Fetch Record 2843 2844 2845 2846# --- get info about field-types etc ---------------------------------------- 2847sub GetAllFieldInfo ($$) # Db 2848{ 2849 my $cTablePI = shift; # not needed at the moment 2850 my $hFldInfoSetPI = shift; 2851 2852 my $cType; 2853 my $hDB; 2854 my $hStmt; 2855 my $iInd; 2856 my $plTypes; 2857 my %hTypeNames; 2858 my @lLen; 2859 my $plNames; 2860 2861 $hDB = $hFldInfoSetPI->DBHdl(); 2862 2863 $plNames = $hFldInfoSetPI->AllNames(); 2864 $plTypes = $hFldInfoSetPI->AllTypes(); 2865 2866 foreach $iInd (0 .. $#{$plNames}) 2867 { 2868 my $cFieldName = $plNames->[$iInd]; 2869 my $iFieldType = $plTypes->[$iInd]; 2870 2871 # some drivers use their own db-specific type-coding 2872 $iFieldType = &DbSession::MapDatatype($iFieldType) 2873 unless defined &DbSession::NameOfType($iFieldType); 2874 2875 printf STDERR ("TypeInfo %s -> (%s,%s): T: <%s>\n", 2876 $cFieldName, 2877 $plTypes->[$iInd], 2878 $iFieldType, 2879 &DbSession::NameOfType($iFieldType)) 2880 if &GetAttr("DebugLvl") > 0; 2881 2882 $hTableInfoMGL{$cFieldName}{"PRECISION"} = 0; 2883 $hTableInfoMGL{$cFieldName}{"TYPE"} = $iFieldType; 2884 $hTableInfoMGL{$cFieldName}{"TYPE_NAME"} = 2885 &DbSession::NameOfType($iFieldType); 2886 } 2887} 2888 2889 2890 2891=head2 OkForm - Display a form similar to a popup-window 2892 2893=over 2 2894 2895=item B<DESCRIPTION> 2896 2897Generates a complete HTML-Form, to inform the user about an error, 2898a warning, an information or anything else. 2899 2900=item B<SYNOPSIS> 2901 2902OkForm($type, $text [, $btn]) 2903 2904 type - error, die, yes-no or blank ("") 2905 text - The text, you want to display 2906 btn - (Optional) The name, you want to give the Ok-button 2907 2908=item B<RETURN VALUE> 2909 2910None. 2911 2912=item B<EXAMPLE> 2913 2914 # The Record has not been found 2915 &OkForm("error", "Sorry, but the record couldn't be found!"); 2916 2917=item B<SEE ALSO> 2918 2919Error 2920 2921=back 2922 2923=cut 2924 2925# --- show OK-Form --------------------------------------------------------- 2926sub OkForm ($$;$) # HTML 2927{ 2928 2929 my ($cTypePI, $cTextPI, $cBtnPI) = @_; 2930 2931 my $cBtn = $cBtnPI; 2932 my $cHeaderMsg; 2933 my $cText = $cTextPI; 2934 my $cType = lc($cTypePI); 2935 my $oHtmlTableApp; 2936 2937 2938 # error-messages get another header 2939 if ($cType eq "error") 2940 { 2941 $cHeaderMsg = i18n("Problem!!"); 2942 } 2943 elsif ($cType eq "die") 2944 { 2945 $cHeaderMsg = i18n("Fatal Error!!"); 2946 } 2947 elsif ($cType eq "yes-no") 2948 { 2949 # Here the User can manipulate form-data 2950 Plugin->new("PreCreateForm")->Call(); 2951 2952 $cHeaderMsg = i18n("Confirmation"); 2953 } 2954 else 2955 { 2956 # Here the User can manipulate form-data 2957 Plugin->new("PreCreateForm")->Call(); 2958 2959 $cHeaderMsg = i18n("Information"); 2960 } 2961 2962 # Application-Table 2963 { 2964 $oHtmlTableApp = HTML::Table->new 2965 (BorderPar => &MyVal('Layout Table', 'Border', '0'), 2966 BgColorPar => &MyUserVal('Layout Table', 2967 'BgColor', 2968 $cBgColorMGL), 2969 WidthPar => "100%", 2970 HeightPar => "100%"); 2971 2972 # The text of the message 2973 $oHtmlTableApp->Element(0, 0, 0, p($cText)); 2974 2975 # create the buttons 2976 if ($cType eq "yes-no") 2977 { 2978 $oHtmlTableApp->Element 2979 (1, 0, 0, 2980 &SubmitButton("BtnYes", 2981 &EncodeHtml(i18n("Yes"))), 2982 &SubmitButton("BtnNo" , 2983 &EncodeHtml(i18n("No")))); 2984 } 2985 else 2986 { 2987 $oHtmlTableApp->Element 2988 (1, 0, 0, 2989 &SubmitButton((defined($cBtnPI)? $cBtnPI: "BtnOk"), 2990 &EncodeHtml(i18n("OK")))) 2991 if $cBtnPI ne "-"; 2992 } 2993 2994 # center all lines 2995 foreach (0..1) 2996 { 2997 $oHtmlTableApp->Element($_)->setAlignPar("Center") 2998 if defined $oHtmlTableApp->Element($_); 2999 } 3000 } 3001 3002 # all hidden fields 3003 $oHtmlTableApp->Element(HTML::Table::APPEND, 0, 0, 3004 &GenPageHidden()); 3005 3006 if ($cType eq "die") 3007 { 3008 &InitHTMLForm(); 3009 3010 my $oTemplate = HTML::Template->new 3011 (filename => (&GetAttr("BaseDir") . 3012 &MyVal('WWWdb', "Template", 3013 "/lib/WWWdb/Templ/Tmpl_WWWdb.html")), 3014 die_on_bad_params => 0, 3015 debug => 1); 3016 3017 $oTemplate->param('APPL' => $oHtmlTableApp->HtmlCode()); 3018 $oTemplate->param('HIER_FORM' => &HierarchyForm()); 3019 3020 $oFormMGL->Element(0, &ScanDoc($oTemplate->output)); 3021 3022 } 3023 else 3024 { 3025 &GenHtmlForm(undef, $oHtmlTableApp->HtmlCode(), undef); 3026 3027 } 3028 3029} # sub OkForm 3030 3031sub InitHTMLForm() 3032{ 3033 my %hFormParam = (); 3034 3035 3036 # set the params for the form 3037 $hFormParam{"ExpireHeadPar"} = ($iCacheTimeoutMGL? 3038 "+" . $iCacheTimeoutMGL . "s": 3039 "now"); 3040 3041 $hFormParam{"MetaHtmlPar"} = {"keywords" => "WWWdb", # FIXME: meta-keywords 3042 }; 3043 $hFormParam{"AuthorHtmlPar"} = &UnTaint($ENV{"SERVER_ADMIN"}); 3044 $hFormParam{"TitleHtmlPar"} = (i18n(&MyVal 3045 ("Header", 3046 "Title", 3047 "WWWdb"))); 3048 $hFormParam{"BackgroundHtmlPar"} = ("/" . 3049 &GetAttr("ScriptName") . 3050 "/lib/". 3051 $cBgImageMGL) 3052 if $cBgImageMGL; 3053 $hFormParam{"BgColorHtmlPar"} = $cBgColorMGL 3054 if $cBgColorMGL; 3055 3056 foreach ("Link", "ALink", "VLink") 3057 { 3058 my $cValue = &MyVal('GUI', "$_" . "Color", undef); 3059 3060 $hFormParam{$_ . "HtmlPar"} = $cValue 3061 if defined $cValue; 3062 } 3063 3064 $hFormParam{"ActionFormPar"} = 3065 &CreateReference(&GetAttr("SessionId"), 3066 (&GetAttr("ConfigFile"))); 3067 3068 $oFormMGL = HTML::Form->new(%hFormParam); 3069 3070 return; 3071 3072} 3073 3074# --- Generate the HTML-code using some templates --------------------------- 3075sub GenHtmlForm ($$$) # HTML (ConfigFile) 3076{ 3077 my $cTableHeaderPI = shift; 3078 my $cApplPI = shift; 3079 my $cTableFooterPI = shift; 3080 3081 my %hTemplParam = (); 3082 3083 # HTML::Template supports only lowercase variables, 3084 # so we have to convert the standard_templates 3085 my %hPluginMap = ("formheader" => "FormHeader", 3086 "formfooter" => "FormFooter", 3087 "firstcolumn" => "FirstColumn", 3088 "preformheader" => "PreFormHeader", 3089 "preformfooter" => "PreFormFooter", 3090 "prefirstcolumn" => "PreFirstColumn", 3091 "postformheader" => "PostFormHeader", 3092 "postformfooter" => "PostFormFooter", 3093 "postfirstcolumn" => "PostFirstColumn",); 3094 3095 &InitHTMLForm(); 3096 3097 my $oTemplate = HTML::Template->new 3098 (filename => (&GetAttr("BaseDir") . 3099 &MyVal('WWWdb', "Template", 3100 "/lib/WWWdb/Templ/Tmpl_WWWdb.html")), 3101 die_on_bad_params => 0, 3102 debug => &GetAttr("DebugLvl") + 100); 3103 3104 if ($oTemplate->query(name => 'APPL')) 3105 { 3106 $hTemplParam{'APPL'} = $cApplPI; 3107 3108 } 3109 3110 printf STDERR "HDR: $cTableHeaderPI\n"; 3111 printf STDERR "FTR: $cTableFooterPI\n"; 3112 $hTemplParam{'TABLE_HEADER'} = "TableHeader"; 3113 $hTemplParam{'TABLE_FOOTER'} = "TableFooter"; 3114 3115 if ($oTemplate->query(name => 'TABLE_HEADER')) 3116 { 3117 $hTemplParam{'TABLE_HEADER'} = $cTableHeaderPI; 3118 } 3119 3120 if ($oTemplate->query(name => 'TABLE_FOOTER')) 3121 { 3122 $hTemplParam{'TABLE_FOOTER'} = $cTableFooterPI; 3123 } 3124 3125 if ($oTemplate->query(name => 'PATH_FORM')) 3126 { 3127 $hTemplParam{'PATH_FORM'} = &PathForm(" ", " > ", " "); 3128 3129 } 3130 3131 if ($oTemplate->query(name => 'SUBCAT_FORM')) 3132 { 3133 $hTemplParam{'SUBCAT_FORM'} = &SubCategoriesForm(); 3134 3135 } 3136 3137 if ($oTemplate->query(name => 'HIER_FORM')) 3138 { 3139 $hTemplParam{'HIER_FORM'} = &HierarchyForm(); 3140 3141 } 3142 3143 if ($oTemplate->query(name => 'LOGIN_FORM')) 3144 { 3145 $hTemplParam{'LOGIN_FORM'} = &LoginForm(); 3146 3147 } 3148 3149 if ($oTemplate->query(name => 'SEARCH_FORM')) 3150 { 3151 $hTemplParam{'SEARCH_FORM'} = &SearchForm(); 3152 3153 } 3154 3155 if ($oTemplate->query(name => 'LANG_FORM')) 3156 { 3157 $hTemplParam{'LANG_FORM'} = &LangForm(); 3158 3159 } 3160 3161 # find program parameters and fill them in 3162 my @lParams = $oTemplate->param(); 3163 for my $cParam (@lParams) 3164 { 3165 if ($cParam =~ /^__plugin_(.*)__$/) 3166 { 3167 my $cPluginName = (defined $hPluginMap{$1}? 3168 $hPluginMap{$1}: 3169 $1); 3170 3171 $hTemplParam{$cParam} = 3172 (Plugin->new("$cPluginName", 3173 "HasPrePost" => 0, 3174 "HasMy" => 1)->Call()); 3175 } 3176 } 3177 3178 # fill in some parameters 3179 $oTemplate->param(\%hTemplParam); 3180 3181 # Resolve WWWdb-links 3182 $oFormMGL->Element(0, &ScanDoc($oTemplate->output)); 3183 3184 print STDERR Dumper($oFormMGL) 3185 if &GetAttr("DebugLvl") > 3; 3186 3187 3188} 3189 3190 3191 3192# --- generate a page with all entry-fields hidden ------------------------- 3193sub GenPageHidden () # HTML ConfigFile CGI 3194{ 3195 my $cResult = ""; 3196 3197 foreach (keys %hFormDataMGL) 3198 { 3199 if (/^Fld[^_].*$/) 3200 { 3201 $cResult .= hidden(-name => $_, 3202 -value => &EncodeHtml(&MyParam($_))) . "\n"; 3203 } 3204 } 3205 3206# foreach $cField (split ", ", &MyVal("Data", "UpdFields")) 3207# { 3208# $cResult .= hidden(-name => "Fld" . $cField, 3209# -value => &EncodeHtml(&MyParam("Fld" . 3210# $cField))) . 3211# "\n"; 3212# } 3213 3214 return $cResult; # FIXME: Why does this return results in wrong data? 3215} # sub GenPageHidden 3216 3217 3218# --- generate the HTML-page for entering all the data --------------------- 3219sub GenPage () # HTML (ConfigFile CGI) 3220{ 3221 my $iInd; 3222 my $cHeaderText; 3223 my $iMaxCol; 3224 my $oHtmlTableApp; 3225 my $oErrTextCol = undef; 3226 my @lColsWithFullWidth = (); 3227 3228 3229 # Here the User can manipulate form-data 3230 Plugin->new("PreCreateForm")->Call(); 3231 3232 if(&MyParam("WWWdbState") eq "Init") 3233 { 3234 $cHeaderText = &MyVal("State Init", "Header", 3235 i18n("Search-criteria / insert data")); 3236 } 3237 elsif(&MyParam("WWWdbState") eq "Work") 3238 { 3239 $cHeaderText = &MyVal("State Work", "Header", 3240 i18n("Work on this record")); 3241 } 3242 elsif(&MyParam("WWWdbState") eq "Qry") 3243 { 3244 $cHeaderText = &MyVal("State Qry", "Header", 3245 i18n("Browse or select data")); 3246 } 3247 3248 3249 # show table ------------------------------------------------------- 3250 { 3251 my $cField; 3252 my $cFieldType; 3253 my $cPos; 3254 my $cPosKey; 3255 my $iCol; 3256 my $iIndPosKey; 3257 my $iLine; 3258 my $iLineOffset; 3259 my $iMaxLine; 3260 my $iPosCol; 3261 my $iPosLine; 3262 my $iPosSequence; 3263 my $iColSpan; 3264 my $iRowSpan; 3265 my $iSequence; 3266 my %hFieldInfo; 3267 my @lcFields; 3268 my @lcPosKey; 3269 my $cTableBackground; 3270 3271 # read all fields of the configuration-file and calculate their 3272 # positions in the HTML-table 3273 { 3274 3275 my $cSection; 3276 my $cParam; 3277 my $cValue; 3278 my $cCurrPos; 3279 3280 $cCurrPos = "000.000.000.000"; 3281 3282 # scan all sections 3283 foreach $cSection ($oConfPoolGL->getSectionNames()) 3284 { 3285 3286 # scan all parameters 3287 foreach $cParam ($oConfPoolGL->getEntryNames($cSection)) 3288 { 3289 if (($cSection =~ /^Layout\s+(Label|Field)/) and 3290 (lc($cParam) eq "pos")) 3291 { 3292 my $cField; 3293 my $cFieldType; 3294 my $cDummy; 3295 3296 ($cDummy, $cFieldType, $cField) = split(" ", $cSection); 3297 3298 # calculate position and insert in hash 3299 &MakeNewPosEntry 3300 ($cFieldType, 3301 $cField, 3302 $oConfPoolGL->getValue($cSection, $cParam), 3303 $cCurrPos, 3304 \%hFieldInfo); 3305 3306 $cCurrPos = $hFieldInfo{"$cField.$cFieldType"}{"Pos"}; 3307 3308 } 3309 } 3310 } 3311 } 3312 3313 # Now we have a correct sequence of the fields ... 3314 @lcPosKey = sort keys %{$hFieldInfo{"Pos"}}; 3315 3316 $iMaxLine = 0; 3317 $iMaxCol = 0; 3318 3319 # let's count the maximum lines and columns 3320 foreach $cPosKey (@lcPosKey) 3321 { 3322 ($iLine, $iCol) = split /\./, $cPosKey; 3323 3324 $iMaxLine = $iLine if ($iMaxLine < $iLine); 3325 $iMaxCol = $iCol if ($iMaxCol < $iCol); 3326 } 3327 3328 # Now we have to look for all fields in the table, which have 3329 # been "forgotten" in the config-file 3330 3331 { 3332 # We dont need no Record-ID 3333 # push @lcFields, split ", ", &MyVal('Data', 'IdField'); 3334 push @lcFields, split ", ", &MyVal('Data', 'UpdFields'); 3335 push @lcFields, split ", ", &MyVal('Data', 'ExtraFields'); 3336 3337 # fill the array 3338 foreach $cField (@lcFields) 3339 { 3340 my $cFieldPos; 3341 my $iSequence; 3342 my $iWidth; 3343 3344 # is this field configured? 3345 $cFieldPos = &MyVal("Layout Field $cField", "Pos", ""); 3346 3347 # NO! 3348 if(!$cFieldPos) 3349 { 3350 3351 $iMaxLine ++; 3352 3353 # Append the label in the first column at the last row 3354 &MakeNewPosEntry("Label", 3355 $cField, 3356 "$iMaxLine.0.0", 3357 "$iMaxLine.0.0", 3358 \%hFieldInfo); 3359 3360 # Append the field in the second column at the last row 3361 &MakeNewPosEntry("Field", 3362 $cField, 3363 "$iMaxLine.1.0", 3364 "$iMaxLine.1.0", 3365 \%hFieldInfo); 3366 3367 # Maybe we have to correct the max. column 3368 $iMaxCol = 1 if $iMaxCol < 1; 3369 } 3370 3371 } # foreach $cFieldType ("Field", "Label") 3372 3373 } # foreach $cField ... 3374 3375 3376 # again we need the correct order of the fields ... 3377 @lcPosKey = sort keys %{$hFieldInfo{"Pos"}}; 3378 $iIndPosKey = 0; 3379 3380 $cTableBackground = &MyVal('Layout Table', 'Background', ""); 3381 3382 $cTableBackground = &GenImage($cTableBackground) 3383 if $cTableBackground; 3384 3385 $oHtmlTableApp = HTML::Table->new 3386 (BorderPar => &MyVal('Layout Table', 'Border', '0'), 3387 BackgroundPar => $cTableBackground, 3388 BgColorPar => &MyUserVal('Layout Table', 3389 'BgColor', 3390 $cBgColorMGL), 3391 WidthPar => "100%", 3392 HeightPar => "100%"); 3393 3394 $oHtmlTableApp->Element(HTML::Table::APPEND, 0, 0, 3395 b(&EncodeHtml(i18n($cHeaderText)))); 3396 $oHtmlTableApp->Element 3397 (HTML::Table::CURRENT, 0)->setAlignPar("Center"); 3398 3399 # mark for enlarging later 3400 push @lColsWithFullWidth, $oHtmlTableApp->Element(0, 0); 3401 3402 # show standard error-text 3403 if (%hFieldErrorsMGL) 3404 { 3405 $oHtmlTableApp->Element 3406 (HTML::Table::APPEND, 0, 0, 3407 font({-color => 'Red', 3408 -size => 3}, 3409 b(&EncodeHtml 3410 (i18n("While checking your input-data some problems " . 3411 "were detected and marked. <BR>" . 3412 "Some explanation of the problems, you have " . 3413 "to solve first is on the bottom of this page"))))); 3414 3415 push (@lColsWithFullWidth, 3416 $oHtmlTableApp->Element(HTML::Table::CURRENT, 0)); 3417 } 3418 3419 # Now we are ready to construct the table!!! 3420 $iLineOffset = $oHtmlTableApp->getMaxRow() - 1; 3421 3422 foreach (@lcPosKey) 3423 { 3424 my $cCellType; 3425 3426 ($cField, $cCellType) = 3427 split /\./, $hFieldInfo{"Pos"}{$_}; 3428 3429 # splits $_ and converts to integer 3430 ($iPosLine, $iPosCol, $iPosSequence, $iRowSpan, $iColSpan) = 3431 map {int($_)} split /\./, $_; 3432 3433 # make a new column-object 3434 { 3435 my $cConfKey; 3436 my $oColumn; 3437 my $cBackground; 3438 my %hAttribs = (); 3439 3440 $cConfKey = "Layout $cCellType $cField"; 3441 3442 3443 $cBackground = &MyVal($cConfKey, 'Background', ""); 3444 3445 $cBackground = &GenImage($cBackground) 3446 if $cBackground; 3447 3448 $hAttribs{"BackgroundPar"} = $cBackground 3449 if $cBackground; 3450 3451 $hAttribs{"BgColorPar"} = &MyVal($cConfKey, "BgColor", $cBgColorMGL) 3452 if &MyVal($cConfKey, "BgColor", $cBgColorMGL); 3453 $hAttribs{"AlignPar"} = &MyVal($cConfKey, "Align", "") 3454 if &MyVal($cConfKey, "Align", ""); 3455 $hAttribs{"ValignPar"} = &MyVal($cConfKey, "VAlign", "") 3456 if &MyVal($cConfKey, "VAlign", ""); 3457 $hAttribs{"NowrapPar"} = "NOWRAP" 3458 if &MyVal($cConfKey, "NoWrap", ""); 3459 3460 $oColumn = HTML::TableCol->new(%hAttribs); 3461 3462 $oHtmlTableApp->Element($iPosLine + $iLineOffset, 3463 $iPosCol, 3464 $oColumn); 3465 } 3466 3467 3468 $oHtmlTableApp->Element($iPosLine + $iLineOffset, 3469 $iPosCol, 3470 $iPosSequence, 3471 &GenField($cCellType, 3472 $cField, 3473 &MyParam("Fld$cField"))); 3474 3475 $oHtmlTableApp->Element 3476 ($iPosLine + $iLineOffset, $iPosCol)->setColspanPar($iColSpan) 3477 if $iColSpan > 1; 3478 $oHtmlTableApp->Element 3479 ($iPosLine + $iLineOffset, $iPosCol)->setRowspanPar($iRowSpan) 3480 if $iRowSpan > 1; 3481 } 3482 } 3483 3484 $oHtmlTableApp->Element (HTML::Table::APPEND, 0, 0, ""); 3485 3486 $iInd = 0; 3487 # scan multiple primary-keys 3488 3489 # With multiline-fields this makes problems, because some fields 3490 # are defined twice and appear like a array (here for example 3491 # all id_fields) 3492# foreach (split /, /, &GetAttr("RecIdField")) 3493# { 3494# $oHtmlTableApp->Element 3495# (HTML::Table::CURRENT, 3496# 0, 3497# $iInd ++, 3498# hidden(-name => "Fld" . $_, 3499# -value => (&EncodeHtml 3500# (&MyParam("Fld" . $_))))); 3501# 3502# } 3503 3504 # Did an error occur? 3505 if (%hFieldErrorsMGL) 3506 { 3507 my $cField; 3508 my $cResult = ""; 3509 3510 $cResult .= 3511 font({-color => 'Red', 3512 -size => 3}, 3513 b(&EncodeHtml 3514 (i18n("This is a list of the problems appeared:<BR>")))); 3515 3516 foreach $cField (keys %hFieldErrorsMGL) { 3517 $cResult .= 3518 font({-color => 'Red', 3519 -size => 2}, 3520 li(b(&EncodeHtml("$hFieldErrorsMGL{$cField}<BR>")))); 3521 3522 } 3523 3524 $oHtmlTableApp->Element(HTML::Table::APPEND, 0, 0, $cResult); 3525 3526 push (@lColsWithFullWidth, 3527 $oHtmlTableApp->Element(HTML::Table::CURRENT, 0)); 3528 } 3529 3530 3531 $oHtmlTableApp->Element(HTML::Table::APPEND, 0, 0, 3532 &FormButtons()); 3533 push (@lColsWithFullWidth, 3534 $oHtmlTableApp->Element(HTML::Table::CURRENT, 0)); 3535 3536 foreach (@lColsWithFullWidth) 3537 { 3538 $_->setColspanPar($oHtmlTableApp->getMaxCol()); 3539 } 3540 3541 &GenHtmlForm(undef, $oHtmlTableApp->HtmlCode(), undef); 3542 3543} # sub GenPage 3544 3545 3546sub GenField($$$) # HTML (ConfigFile) 3547{ 3548 my $cCellTypePI = shift; 3549 my $cFieldPI = shift; 3550 my $cValuePI = shift; 3551 3552 my $cFieldType; 3553 my $cConfKey; 3554 my $cAttr; 3555 my $cResult = ""; 3556 my @lValues; 3557 my @lAttr = ("H1=H1", 3558 "H2=H2", 3559 "H3=H3", 3560 "H4=H4", 3561 "H5=H5", 3562 "H6=H6", 3563 3564 "Cite=CITE", 3565 "Code=CODE", 3566 "Del=DEL", 3567 "Em=EM", 3568 "Ins=INS", 3569 "Pre=PRE", 3570 "Strong=STRONG", 3571 "TT=TT", 3572 3573 "Big=BIG", 3574 "Blink=BLINK", 3575 "Bold=B", 3576 "Italic=I", 3577 "NoBr=NOBR", 3578 "Small=SMALL", 3579 "Strike=STRIKE", 3580 "Sub=SUB", 3581 "Sup=SUP", 3582 ); 3583 3584 my $oPlugErrLabel = 3585 Plugin->new("ErrLabel", 3586 "HasPrePost" => 1, 3587 "HasMy" => 1); 3588 3589 @lValues = split /\\,/, $cValuePI; 3590 3591 $cConfKey = "Layout $cCellTypePI $cFieldPI"; 3592 3593 $cFieldType = &MyVal($cConfKey, "Type", 3594 ($cCellTypePI eq "Qry"? 3595 "Label": 3596 "Text")); 3597 3598 3599 # if the field is an id-field, it must be read-only 3600 if(&MyParam("WWWdbState") eq "Work") 3601 { 3602 foreach (split /, /, &GetAttr("RecIdField")) 3603 { 3604 if ($_ eq $cFieldPI) 3605 { 3606 $cFieldType = "Label" 3607 if $cFieldType ne "Hidden"; 3608 3609 last; 3610 } 3611 } 3612 } 3613 3614 3615 if ($cCellTypePI eq "Qry") 3616 { 3617 $cResult .= "<SMALL>"; 3618 3619 $cFieldPI = "_" . $cFieldPI; 3620 3621 } 3622 3623 # switch on attributes 3624 foreach $cAttr (@lAttr) 3625 { 3626 my $cConfAttr; 3627 my $cHtmlAttr; 3628 3629 ($cConfAttr, $cHtmlAttr) = split /=/, $cAttr; 3630 3631 # Attribute defined? Generate it! 3632 if(&MyVal($cConfKey, $cConfAttr, "")) 3633 { 3634 $cResult .= ("<$cHtmlAttr>"); 3635 } 3636 } 3637 3638 3639 # Font-Attribute 3640 if(&MyVal($cConfKey, "Font", "")) 3641 { 3642 $cResult .= ("<FONT " . 3643 &MyVal($cConfKey, "Font", "") . 3644 ">"); 3645 } 3646 3647 if($cCellTypePI eq "Label") 3648 { 3649 my $cText; 3650 my $cRef = &MyVal($cConfKey, "Ref"); 3651 my $cImg = &MyVal($cConfKey, "Image"); 3652 3653 if($cRef) 3654 { 3655 $cText = &ResolveRefField($cRef, 3656 i18n(&MyVal($cConfKey, "Text", $cRef))); 3657 } 3658 else 3659 { 3660 $cText = i18n(&MyVal($cConfKey, "Text", $cFieldPI)); 3661 } 3662 3663 3664 if($cImg) 3665 { 3666 $cText = GenImage($cImg, 3667 $cText, 3668 &MyVal($cConfKey, "ImgBorder")); 3669 3670 3671 } 3672 # Text of label 3673 $cResult .= &EncodeHtml($cText); 3674 3675 } # if($cCellTypePI eq "Label") 3676 else 3677 { 3678 $cResult .= &EncodeHtml($oPlugErrLabel->Call("Fld$cFieldPI")); 3679 3680 if($cFieldType eq "HTML") 3681 { 3682 3683 # include a HTML-Page 3684 if(-r &MyVal($cConfKey, "File")) 3685 { 3686 $cResult .= &InsertHtmlPage(&MyVal($cConfKey, "File")); 3687 } 3688 3689 } # if($cCellTypePI eq "HTML") 3690 # Entry-Field for text 3691 elsif($cFieldType eq "Text") 3692 { 3693 $cResult .= (textfield (-name => "Fld$cFieldPI", 3694 -maxlength => &MyVal($cConfKey, 3695 "MaxLength", 3696 "100"), 3697 -size => &MyVal($cConfKey, 3698 "Size", 3699 "30"), 3700 -override => 1, 3701 -value => ($lValues[0]), 3702 &CommonInputAttr($cConfKey))); 3703 3704 3705 } # if($cFieldType eq "Text") 3706 # Password-field: input-data is not shown 3707 elsif($cFieldType eq "Password") 3708 { 3709 $cResult .= (password_field(-name => "Fld$cFieldPI", 3710 -maxlength => &MyVal($cConfKey, 3711 "MaxLength", 3712 "100"), 3713 -size => &MyVal($cConfKey, 3714 "Size", 3715 "30"), 3716 -value => ($lValues[0]), 3717 -override => 1, 3718 &CommonInputAttr($cConfKey))); 3719 3720 3721 } # if($cFieldType eq "Password") 3722 # enter data in more than one line 3723 elsif($cFieldType eq "Area") 3724 { 3725 $cResult .= (textarea(-name => "Fld$cFieldPI", 3726 -rows => &MyVal($cConfKey, 3727 "Rows", 3728 "4"), 3729 -columns => &MyVal($cConfKey, 3730 "Size", 3731 "30"), 3732 -override => 1, 3733 -wrap => &MyVal($cConfKey, 3734 "Wrap", 3735 "VIRTUAL"), 3736 -default => ($lValues[0]), 3737 &CommonInputAttr($cConfKey))); 3738 3739 3740 } # if($cFieldType eq "Area") 3741 # enter data in more than one line 3742 elsif($cFieldType eq "File") 3743 { 3744 $cResult .= (filefield(-name => "Fld$cFieldPI", 3745 -size => &MyVal($cConfKey, 3746 "Size", 3747 "80"), 3748 -maxlength => &MyVal($cConfKey, 3749 "MaxLength", 3750 "128000"), 3751 -accept => &MyVal($cConfKey, 3752 "Accept", 3753 "text/*"), 3754 -override => 0, 3755 -default => ($lValues[0]), 3756 &CommonInputAttr($cConfKey))); 3757 3758 3759 } # if($cFieldType eq "Area") 3760 elsif($cFieldType eq "Btn") 3761 { 3762 $cResult .= &SubmitButton("Btn$cFieldPI", 3763 &EncodeHtml(i18n(&MyVal($cConfKey, 3764 "Label", 3765 $cFieldPI)))); 3766 3767 } # if($cFieldType eq "Btn") 3768 # Hidden field, which is not shown on the screen 3769 elsif($cFieldType eq "Hidden") 3770 { 3771 $cResult .= hidden(-name => "Fld$cFieldPI", 3772 -override => 1, 3773 -value => ($lValues[0])); 3774 3775 } # if($cFieldType eq "Hidden") 3776 elsif($cFieldType eq "Label") 3777 { 3778 $cResult .= hidden(-name => ("Fld" . 3779 $cFieldPI), 3780 -override => 1, 3781 -value => ($lValues[0])) 3782 unless $cCellTypePI eq "Qry"; 3783 3784 $cResult .= (&MyVal($cConfKey, "SafeText", "")? 3785 &EncodeHtml(($lValues[0])): 3786 &SafeEncodeHtml(($lValues[0]))); 3787 3788 } # if($cFieldType eq "Label") 3789 elsif($cFieldType eq "Ref") 3790 { 3791 $cResult .= &ResolveRefField($lValues[0], 3792 &MyVal($cConfKey, "Value", "->")); 3793 3794 } # if($cFieldType eq "Ref") 3795 elsif($cFieldType eq "RecordRef") 3796 { 3797 $cResult .= a({href => 3798 &CreateReference(&GetAttr("SessionId"), 3799 (&GetAttr("ConfigFile") . 3800 ";BtnSelect=" . 3801 $lValues[1]))}, 3802 &EncodeHtml(i18n($lValues[0]))); 3803 3804 } # if($cFieldType eq "RecordRef") 3805 # Selection-List with more possible values 3806 elsif(($cFieldType eq "Select") or 3807 ($cFieldType eq "Radio")) 3808 { 3809 my %hLabels = undef; 3810 my @lListValues = undef; 3811 3812 if (0) # FIXME: kick out .... 3813 { 3814 my $cValLabel; 3815 my @lValLabel; 3816 3817 @lValLabel = &MyListVal($cConfKey, "Values", ""); 3818 3819 # if this is a SQL-Statement, then execute it 3820 if ($lValLabel[0] =~ /^select/i) 3821 { 3822 my $pResult; 3823 3824 $pResult = $oDbTargetGL->SqlSelect 3825 (i18n(join "\n", @lValLabel)); 3826 # (i18n(join "\n", @lValLabel)); FIXME 3827 3828 @lValLabel = @{$pResult}; 3829 } 3830 else 3831 { 3832 # splits the xxxx\\,yyy into [xxxx, yyyy] 3833 @lValLabel = map {[split /\\,/]} @lValLabel; 3834 } 3835 3836 # make an "undefined" label e.g. for searching 3837 unshift @lValLabel, ["", i18n("Undefined")] 3838 unless &MyVal($cConfKey, "NoUndef", ""),; 3839 3840 # Split the Value,Label list in two Arrays 3841 foreach $cValLabel (@lValLabel) 3842 { 3843 # $cValLabel = i18n($cValLabel); 3844 3845 # do we have a value and a label? 3846 if (ref $cValLabel) 3847 { 3848 push @lListValues, $cValLabel->[0]; 3849 $hLabels{$cValLabel->[0]} = i18n($cValLabel->[1]); 3850 } 3851 else 3852 { 3853 push @lListValues, $cValLabel; 3854 $hLabels{$cValLabel} = i18n($cValLabel); 3855 } 3856 } 3857 } 3858 3859 my @lResult = &GetSelectboxValues($cFieldPI); 3860 3861 @lListValues = @{$lResult[0]}; 3862 %hLabels = %{$lResult[1]}; 3863 3864 $hSelectCacheMGL{$cFieldPI} = \%hLabels; 3865 3866 if($cFieldType eq "Select") 3867 { 3868 3869 $cResult .= (scrolling_list(-multiple => (&MyVal($cConfKey, 3870 "Multiple", 3871 "")? "true": "0"), 3872 -name => "Fld$cFieldPI", 3873 -values => \@lListValues, 3874 -labels => \%hLabels, 3875 -override => 1, 3876 -size => &MyVal($cConfKey, 3877 "Rows", 3878 "1"), 3879 -default => \@lValues, 3880 &CommonInputAttr($cConfKey))); 3881 3882 } #if($cFieldType eq "Select") 3883 # Selection with Radio-buttons 3884 elsif($cFieldType eq "Radio") 3885 { 3886 $cResult .= (radio_group(-name => "Fld$cFieldPI", 3887 -values => \@lListValues, 3888 -labels => \%hLabels, 3889 -override => 1, 3890 -default => $lValues[0], 3891 &CommonInputAttr($cConfKey))); 3892 3893 } #if($cFieldType eq "Select") 3894 } # if($cFieldType eq "Select") or ($cFieldType eq "Radio")) 3895 # Check-Button 3896 elsif($cFieldType eq "Checkbutton") 3897 { 3898 $cResult .= (checkbox(-name => "Fld$cFieldPI", 3899 -checked => $lValues[0], 3900 -value => i18n(&MyVal($cConfKey, 3901 "Value", 3902 "1")), 3903 -override => 1, 3904 -label => (&MyVal($cConfKey, 3905 "Text", 3906 i18n($cFieldPI))), 3907 &CommonInputAttr($cConfKey))); 3908 3909 } #if($cFieldType eq "Select") 3910 } # else ($cCellTypePI eq "Label") 3911 3912 # switch off Font-Attribute 3913 if(&MyVal($cConfKey, "Font", "")) 3914 { 3915 $cResult .= "</FONT>"; 3916 } 3917 3918 # switch off Attributes 3919 foreach $cAttr (reverse @lAttr) 3920 { 3921 my $cConfAttr; 3922 my $cHtmlAttr; 3923 3924 ($cConfAttr, $cHtmlAttr) = split /=/, $cAttr; 3925 3926 if(&MyVal($cConfKey, $cConfAttr, "")) 3927 { 3928 $cResult .= "</$cHtmlAttr>"; 3929 } 3930 3931 } 3932 3933 3934 $cResult .= "</SMALL>" 3935 if $cCellTypePI eq "Qry"; 3936 3937 return $cResult; 3938 3939} 3940 3941 3942sub GetSelectboxValues($) 3943{ 3944 my $cFieldNamePI = shift; 3945 3946 my $cConfKey = "Layout Field $cFieldNamePI"; 3947 my $cValLabel; 3948 my %hLabels = (); 3949 my @lValLabel; 3950 my @lListValues = (); 3951 my @lResult = (); 3952 3953 @lValLabel = &MyListVal($cConfKey, "Values", ""); 3954 3955 # if this is a SQL-Statement, then execute it 3956 if ($lValLabel[0] =~ /^select/i) 3957 { 3958 my $pResult; 3959 3960 $pResult = $oDbTargetGL->SqlSelect 3961 (i18n(join "\n", @lValLabel)); 3962 # (i18n(join "\n", @lValLabel)); FIXME 3963 3964 @lValLabel = @{$pResult}; 3965 } 3966 else 3967 { 3968 # splits the xxxx\\,yyy into [xxxx, yyyy] 3969 @lValLabel = map {[split /\\,/]} @lValLabel; 3970 } 3971 3972 # make an "undefined" label e.g. for searching 3973 unshift @lValLabel, ["", i18n("Undefined")] 3974 unless &MyVal($cConfKey, "NoUndef", ""),; 3975 3976 # Split the Value,Label list in two Arrays 3977 foreach $cValLabel (@lValLabel) 3978 { 3979 # $cValLabel = i18n($cValLabel); 3980 3981 # do we have a value and a label? 3982 if (ref $cValLabel) 3983 { 3984 push @lListValues, $cValLabel->[0]; 3985 $hLabels{$cValLabel->[0]} = i18n($cValLabel->[1]); 3986 } 3987 else 3988 { 3989 push @lListValues, $cValLabel; 3990 $hLabels{$cValLabel} = i18n($cValLabel); 3991 } 3992 } 3993 3994 push @lResult, \@lListValues; 3995 push @lResult, \%hLabels; 3996 3997 return @lResult; 3998} 3999 4000 4001# --- set some common attributes for input-fields -------------------------- 4002sub CommonInputAttr ($) # HTML 4003{ 4004 my $cConfKeyPI = shift; 4005 4006 my $cResult; 4007 4008 $cResult = ((&MyVal($cConfKeyPI, "Disabled", "")? 4009 " DISABLED ": 4010 "") . 4011 (&MyVal($cConfKeyPI, "Readonly", "")? 4012 " READONLY ": 4013 "") . 4014 (&MyVal($cConfKeyPI, "Tabindex", "")? 4015 " TABINDEX=".&MyVal($cConfKeyPI, "Tabindex", "0"): 4016 "") . 4017 (&MyVal($cConfKeyPI, "Help", "")? 4018 " TITLE=\"".i18n(&MyVal($cConfKeyPI, "Help", ""))."\"": 4019 "")); 4020 4021 return $cResult; 4022 4023} # sub CommonInputAttr 4024 4025# --- calculate a offset for positioninf of columns ------------------------ 4026sub CalcOffset ($$) # Tool 4027{ 4028 my ($iValuePI, $iOffsetPI) = @_; 4029 4030 my $iResult = $iOffsetPI; 4031 4032 # Handle the form +nnn 4033 if ($iOffsetPI =~ /\+(\d+)/) 4034 { 4035 $iResult = $iValuePI + $1; 4036 } 4037 4038 return $iResult; 4039} # sub CalcOffset 4040 4041 4042# --- create a new position-entry for the table-definitions ---------------- 4043sub MakeNewPosEntry ($$$$\%) # Tool 4044{ 4045 my ($cFieldTypePI, 4046 $cFieldPI, 4047 $cFieldPosPI, 4048 $cCurrFieldPosPI, 4049 $hFieldInfoPIO) = @_; 4050 4051 my $cNewPos; 4052 my $iCol; 4053 my $iLine; 4054 my $iSequence; 4055 my $iCurrCol; 4056 my $iCurrLine; 4057 my $iCurrSequence; 4058 my $iLineSpan; 4059 my $iColSpan; 4060 4061 printf STDERR "MakeNewPosEntry: FieldTypePI, $cFieldPI, $cFieldPosPI\n" 4062 if &GetAttr("DebugLvl") > 2; 4063 4064 ($iLine, $iCol, $iSequence) = split /\./, $cFieldPosPI; 4065 ($iCurrLine, $iCurrCol, $iCurrSequence) = split /\./, $cCurrFieldPosPI; 4066 4067 4068 4069 # +xx-yy: from column xx span yy columns 4070 if($iLine =~ /(\+?\d+)\+(\d+)/) 4071 { 4072 $iLine = &CalcOffset($iCurrLine, $1); 4073 4074 # of course the actual line must be included! 4075 $iLineSpan = $2 + 1; 4076 4077 } 4078 else 4079 { 4080 $iLine = &CalcOffset($iCurrLine, $iLine); 4081 $iLineSpan = 1; 4082 } 4083 4084 # when starting on a new line, columns must start at zero 4085 if($iCurrLine < $iLine) { 4086 $iCurrCol = 0; 4087 $iCurrSequence = 0; 4088 } 4089 # when starting on a new column sequences must start at zero 4090 if($iCurrCol < $iCol) { 4091 $iCurrSequence = 0; 4092 } 4093 4094 4095 # +xx-yy: from column xx span yy columns 4096 if($iCol =~ /(\+?\d+)\+(\d+)/) 4097 { 4098 $iCol = &CalcOffset($iCurrCol, $1); 4099 4100 # of course the actual column must be included! 4101 $iColSpan = $2 + 1; 4102 4103 } 4104 else 4105 { 4106 $iCol = &CalcOffset($iCurrCol, $iCol); 4107 $iColSpan = 1; 4108 } 4109 4110 # when starting on a new column sequences must start at zero 4111 if($iCurrCol < $iCol) { 4112 $iCurrSequence = 0; 4113 } 4114 4115 $iSequence = &CalcOffset($iCurrSequence, $iSequence); 4116 4117 $cNewPos = sprintf("%03d.%03d.%03d.%03d.%03d", 4118 $iLine, 4119 $iCol, 4120 $iSequence, 4121 $iLineSpan, 4122 $iColSpan); 4123 4124 printf STDERR "MakeNewPosEntry: $cNewPos\n" 4125 if &GetAttr("DebugLvl") > 2; 4126 4127 $$hFieldInfoPIO{"$cFieldPI.$cFieldTypePI"}{'Pos'} = $cNewPos; 4128 4129 # create data in hash for sort by position 4130 $$hFieldInfoPIO{'Pos'}{$cNewPos} = "$cFieldPI.$cFieldTypePI"; 4131 4132 printf STDERR "$cFieldPI.$cFieldTypePI = $cNewPos<BR>\n" 4133 if &GetAttr("DebugLvl") > 2; 4134 4135 return $cNewPos; 4136} # sub MakeNewPosEntry 4137 4138 4139# --- Generate the form-header --------------------------------------------- 4140sub TableHeader($) # Plugin 4141{ 4142 my $cTitlePI = shift; 4143 4144 my $cResult = ""; 4145 4146 $cTitlePI = " " 4147 if !$cTitlePI; 4148 4149 $cResult .= 4150 table({-WIDTH => "100%", 4151 -BORDER => 0}, 4152 (TR(td(p({-ALIGN => "LEFT"}, 4153 h4((&EncodeHtml 4154 (i18n(&MyVal("Header", "Title"))))))), 4155 td(p({-ALIGN => "RIGHT"}, 4156 h4(&EncodeHtml(i18n($cTitlePI))))), 4157 ))); 4158 4159 $cResult .= hr({-noshade => 1, 4160 -size => 1}); 4161 4162 return $cResult; 4163 4164} 4165 4166 4167# --- Generate the form-footer --------------------------------------------- 4168sub TableFooter($) # Plugin 4169{ 4170 my $cTitlePI = shift; 4171 4172 my $cResult = ""; 4173 4174 4175 # generated by CVS 4176 my $cRevision = (($iDevelopmentVersionMGL? 4177 i18n("Develop-"): "") . 4178 'Version: ' . 4179 $VERSION . 4180 ', $Date: 2003/04/16 11:25:21 $ '); 4181 4182 # make version-info looking nicer 4183 $cRevision =~ s/ ?\$ ?//g; 4184 $cRevision =~ s/Revision:/i18n("Version:")/e; 4185 $cRevision =~ s/Date:/&i18n(" Date:")/e; 4186 # remove the time 4187 $cRevision =~ s/ (\d\d:){2}\d\d//; 4188 4189 $cResult .= (hr({-noshade => 1, 4190 -size => 1}) . 4191 p({-ALIGN => "CENTER"}, 4192 small("($cRevision)"))); 4193 4194 return $cResult; 4195} 4196 4197 4198sub FormHeader ($) # Plugin 4199{ 4200 my $cTitlePI = shift; 4201 4202 4203} 4204 4205sub FormFooter ($) # Plugin 4206{ 4207 my $cTitlePI = shift; 4208 4209 4210} 4211 4212 4213# --- save actual state in a file for debugging ---------------------------- 4214sub SaveState () # CGI 4215{ 4216 my $cKey; 4217 4218 my $cStateFileName = 4219 (&GetAttr("BaseDir") . 4220 "/tmp/" . 4221 &GetAttr("ScriptName") . 4222 "_state.log"); 4223 4224 open MY_STATE, ">$cStateFileName" or 4225 die(sprintf(i18n("can't open %s!!"), 4226 "$cStateFileName")); 4227 4228 printf STDERR (p(i18n("saved state:"), hr({-noshade => 1, 4229 -size => 1}))) 4230 if &GetAttr("DebugLvl") > 2; 4231 4232 # due to security-reasons thes fields are deleted 4233 foreach $cKey ("!DataSource", "!Database", "!Username", "!Password") 4234 { 4235 &MyParamDelete($cKey); 4236 } 4237 4238 # Hash scanning ... 4239 foreach $cKey (sort keys %hFormDataMGL) 4240 { 4241 if (($cKey !~ /^Btn.*/) && ($cKey !~ /^_.*/)) 4242 { 4243 4244 print STDERR "$cKey='" . &MyParam($cKey) . "'\n" 4245 if &GetAttr("DebugLvl") > 2; 4246 4247 print MY_STATE "$cKey=" . &MyParam($cKey) . "\n"; 4248 4249 $hQryMGL->param (-name => $cKey, 4250 -value => &MyParam($cKey)); 4251 } 4252 else 4253 { 4254 &MyParamDelete($cKey); 4255 } 4256 4257 } 4258 4259 close MY_STATE; 4260 4261 chmod 0666, $cStateFileName; 4262 4263} # sub SaveState 4264 4265 4266 4267# --- Wrapper for param, which keeps %hFormDataMGL in an actual state ------ 4268sub MyParam($;$) # CGI 4269{ 4270 my ($cNamePI, $cValuePI) = @_; 4271 my $cResult = undef; 4272 4273 # assign the value 4274 if (defined($cValuePI)) { 4275 4276 printf STDERR "ACHTUNG!!!!! $cNamePI=$cValuePI<BR>\n" 4277 if !$cNamePI && &GetAttr("DebugLvl"); 4278 4279 $hQryMGL->param(-name => $cNamePI, 4280 -value => $cValuePI); 4281 4282 $hFormDataMGL{$cNamePI} = $cValuePI; 4283 4284 $cResult = $cValuePI; 4285 } 4286 # get the Value 4287 else 4288 { 4289 $cResult = (defined($hFormDataMGL{$cNamePI})? 4290 $hFormDataMGL{$cNamePI}: 4291 undef); 4292 } 4293 4294 return $cResult; 4295} 4296 4297# --- Wrapper for delete, which keeps %hFormDataMGL in an actual state ----- 4298sub MyParamDelete($) # CGI 4299{ 4300 my $cNamePI = shift; 4301 4302 4303 $hQryMGL->delete($cNamePI); 4304 delete $hFormDataMGL{$cNamePI}; 4305 4306} 4307 4308 4309# --- insert HTML-page ----------------------------------------------------- 4310sub InsertHtmlPage($) # HTML 4311{ 4312 my $cHtmlFilePI = shift; 4313 my $cResult = ""; 4314 4315 open TEMPLATE, "<$cHtmlFilePI" or 4316 die(sprintf(i18n("Can't open HTML-File %s!"), 4317 "$cHtmlFilePI")); 4318 4319 while (<TEMPLATE>) 4320 { 4321 $cResult .= &EncodeHtml($_); 4322 } 4323 4324 close TEMPLATE; 4325 4326 return $cResult; 4327} # sub InsertHtmlPage 4328 4329 4330# --- my own die-Handler --------------------------------------------------- 4331sub MyDie # HTML 4332{ 4333 my $cMessagePI = shift; 4334 4335 my $iRow; 4336 my $iCol; 4337 my $oHtmlTableStack; 4338 my @lCallInfo; 4339 my @lColsWithFullWidth = (); 4340 my $cMessage; 4341 my $cAdress = &MyVal('WWWdb', 'MailWebmaster', 4342 ($ENV{"SERVER_ADMIN"})); 4343 my $cSubject = "WWWdb-Bugreport"; 4344 my $cBody = "$cMessagePI\n"; 4345 4346 ($cMessage = $cMessagePI) =~ s/\n/\n<BR>/g; 4347 4348 print STDERR "DIE: $cMessage\n"; 4349 4350 # this is for the table-stack (file, line, procedure) 4351 while (@lCallInfo = (caller($iRow++))[1..3]) 4352 { 4353 $iCol = 0; 4354 4355 # the stack-fields 4356 foreach (@lCallInfo) 4357 { 4358 print STDERR $_ . " "; 4359 } 4360 print STDERR "\n"; 4361 } 4362 4363 $oHtmlTableStack = HTML::Table->new 4364 (BorderPar => 1, 4365 BgColorPar => &MyUserVal('Layout Table', 4366 'BgColor', 4367 $cBgColorMGL), 4368 WidthPar => "100%", 4369 HeightPar => "100%"); 4370 4371 $oHtmlTableStack->Element 4372 (HTML::Table::APPEND, 0, 0, 4373 b(i18n("Oops! The following problem occured within " . 4374 "<B>WWWdb</B>!"))); 4375 push @lColsWithFullWidth, $oHtmlTableStack->Element 4376 (HTML::Table::CURRENT, 0); 4377 4378 $oHtmlTableStack->Element(HTML::Table::APPEND, 0, 0, 4379 ($_ . p(small($cMessage)))); 4380 push @lColsWithFullWidth, $oHtmlTableStack->Element 4381 (HTML::Table::CURRENT, 0); 4382 4383 $oHtmlTableStack->Element(HTML::Table::APPEND, 0, 0, 4384 b(i18n("Call-Stack:"))); 4385 push @lColsWithFullWidth, $oHtmlTableStack->Element 4386 (HTML::Table::CURRENT, 0); 4387 4388 $oHtmlTableStack->Element(HTML::Table::APPEND, 4389 HTML::TableRow->new()); 4390 4391 $iCol = 0; 4392 # Generate the table-header 4393 foreach (i18n("File"), 4394 i18n("Line"), 4395 i18n("Procedure")) 4396 { 4397 $oHtmlTableStack->Element(HTML::Table::CURRENT, $iCol++, 0, 4398 small(b($_))); 4399 } 4400 4401 $iRow = 0; 4402 4403 # this is for the table-stack (file, line, procedure) 4404 while (@lCallInfo = (caller($iRow++))[1..3]) 4405 { 4406 4407 $oHtmlTableStack->Element 4408 (HTML::Table::APPEND, 4409 HTML::TableRow->new(BgColorPar => ($iRow %2? 4410 "#eeeeee": 4411 "#ffffff"))); 4412 4413 $iCol = 0; 4414 4415 # the stack-fields 4416 foreach (@lCallInfo) 4417 { 4418 $oHtmlTableStack->Element(HTML::Table::CURRENT, $iCol++, 0, 4419 small($_)); 4420 $cBody .= " $_"; 4421 } 4422 4423 $cBody .= "\n"; 4424 4425 } 4426 4427 foreach ("LastBtn", 4428 "Lang", 4429 "BaseLang", 4430 "State", 4431 "RecordOk", 4432 "ScriptName", 4433 "HostName", 4434 "DebugLvl", 4435 "BaseDir", 4436 "DbDriver", 4437 "DbHandle", 4438 "ConfigPath", 4439 "ConfigFile", 4440 "SessionId", 4441 "UrlParams", 4442 "LogfileName", 4443 "HTMLfileName", 4444 "RecIdField", 4445 "RecId", 4446 "ObjectId") 4447 { 4448 $cBody .= sprintf("%s = '%s'\n", 4449 $_, &GetAttr($_)); 4450 4451 } 4452 4453 # make this rows full-sized 4454 foreach (@lColsWithFullWidth) 4455 { 4456 $_->setColspanPar($oHtmlTableStack->getMaxCol()); 4457 } 4458 4459 4460 $cSubject =~ s/ /%20/g; 4461 $cBody =~ s/ /%20/g; 4462 $cSubject =~ s/\n/%0D/g; 4463 $cBody =~ s/\n/%0D/g; 4464 4465 $oHtmlTableStack->Element 4466 (HTML::Table::APPEND, 0, 0, 4467 a({HREF => "mailto:$cAdress?subject=$cSubject&body=$cBody"}, 4468 i18n("Please send this bugreport!"))); 4469 4470 # make this rows full-sized 4471 $oHtmlTableStack->Element(HTML::Table::CURRENT, 0)-> 4472 setColspanPar($oHtmlTableStack->getMaxCol()); 4473 4474 &Error($oHtmlTableStack->HtmlCode); 4475 4476} # sub MyDie 4477 4478 4479 4480=head2 Error - show a error-frame and leave 4481 4482 =over 2 4483 4484 =item B<DESCRIPTION> 4485 4486FIXME: add docs 4487 4488 - HTTP-link: http://<host> 4489 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4490 4491 =item B<SYNOPSIS> 4492 4493 $http_ref = ResolveRefField($ref_field, $label); 4494 4495=item B<RETURN VALUE> 4496 4497 A correct HTML-Reference for the values, given as parameters. 4498 4499 =item B<EXAMPLE> 4500 4501 # Generate a Link to WWWdb:Index for the current session and db 4502 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4503 "Main-Index"); 4504 4505=item B<SEE ALSO> 4506 4507=back 4508 4509=cut 4510 4511# --- Show an error frame -------------------------------------------------- 4512 sub Error($) # HTML 4513{ 4514 my $cMessagePI = shift; 4515 4516 my $cMessage = $cMessagePI . "<BR><BR>"; 4517 4518 &OkForm("Die", 4519 "$cMessage"); 4520 4521 $iCacheTimeoutMGL = 0; 4522 4523 &MyExit(); 4524} # sub MyDie 4525 4526 4527 4528=head2 MyExit - leave WWWdb in a clean way 4529 4530=over 2 4531 4532=item B<DESCRIPTION> 4533 4534FIXME: add docs 4535 4536 - HTTP-link: http://<host> 4537 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4538 4539=item B<SYNOPSIS> 4540 4541 $hppt_ref = ResolveRefField($ref_field, $label); 4542 4543=item B<RETURN VALUE> 4544 4545 A correct HTML-Reference for the values, given as parameters. 4546 4547=item B<EXAMPLE> 4548 4549 # Generate a Link to WWWdb:Index for the current session and db 4550 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4551 "Main-Index"); 4552 4553=item B<SEE ALSO> 4554 4555=back 4556 4557=cut 4558 4559# --- exit this program in a clean way ------------------------------------- 4560 sub MyExit() # HTML Db 4561{ 4562 my $iDebugLvl = &GetAttr("DebugLvl"); 4563 4564 # Update the DB now 4565 DBIx::Recordset::Undef("pDataSetMGL"); 4566 4567 Plugin::_UndefAllPlugins(); 4568 4569 if (defined $oFormMGL) 4570 { 4571 print $oFormMGL->HtmlCode(); 4572 } 4573 4574 $oSessionGL = undef; 4575 $oDbSessionGL = undef; 4576 $oDbTargetGL = undef; 4577 4578 close STDERR; 4579 4580 # in debugging-mode generate the whole logfile into HTML 4581 if ($iDebugLvl) 4582 { 4583 open LOGFILE, "<" . &GetAttr("LogfileName") or 4584 die (sprintf("Can't open Log-file %s!", 4585 &GetAttr("LogfileName"))); 4586 4587 print STDOUT "<SMALL><PRE>"; 4588 4589 while (<LOGFILE>) 4590 { 4591 print STDOUT "$_<BR>"; 4592 } 4593 print STDOUT "</PRE></SMALL>"; 4594 4595 close LOGFILE; 4596 4597 } 4598 4599 # dump out the cache-file, when the timeout is set 4600 &CGI::Cache::Stop($iCacheTimeoutMGL? 1: 1); 4601 4602 # expire this document 4603 &CGI::Cache::Expire() 4604 unless $iCacheTimeoutMGL; 4605 4606 exit; 4607 4608} 4609 4610 4611# --- generate label for fields containing errors -------------------------- 4612sub ErrLabel($) # HTML Plugin 4613{ 4614 my $cFieldPI = shift; 4615 4616 return (defined($hFieldErrorsMGL{$cFieldPI})? 4617 font({-color => 'Red'}, 4618 b(" (*)")): 4619 ""); 4620} # sub ErrLabel 4621 4622 4623 4624=head2 MyUserVal - Get an entry of the config-file, but look for session-data before 4625 4626=over 2 4627 4628=item B<DESCRIPTION> 4629 4630FIXME: add docs 4631 4632 - HTTP-link: http://<host> 4633 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4634 4635=item B<SYNOPSIS> 4636 4637 $hppt_ref = ResolveRefField($ref_field, $label); 4638 4639=item B<RETURN VALUE> 4640 4641 A correct HTML-Reference for the values, given as parameters. 4642 4643=item B<EXAMPLE> 4644 4645 # Generate a Link to WWWdb:Index for the current session and db 4646 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4647 "Main-Index"); 4648 4649=item B<SEE ALSO> 4650 4651=back 4652 4653=cut 4654 4655# --- Wrapper for MyVal looking in the SessionId-Table before ------------------- 4656 sub MyUserVal($$;$) # SessionId ConfigFile 4657{ 4658 my ($cSectionPI, $cEntryPI, $cDefaultPI) = @_; 4659 4660 my $cResult = undef; 4661 4662 $cResult = $oSessionGL->getState("[$cSectionPI] $cEntryPI") 4663 if defined($oSessionGL); 4664 4665 if (!defined $cResult) 4666 { 4667 $cResult = &MyVal($cSectionPI, $cEntryPI, $cDefaultPI) 4668 } 4669 4670 return $cResult; 4671} 4672 4673 4674 4675=head2 MyVal - Get an entry of the config-file 4676 4677=over 2 4678 4679=item B<DESCRIPTION> 4680 4681FIXME: add docs 4682 4683 - HTTP-link: http://<host> 4684 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4685 4686=item B<SYNOPSIS> 4687 4688 $hppt_ref = ResolveRefField($ref_field, $label); 4689 4690=item B<RETURN VALUE> 4691 4692 A correct HTML-Reference for the values, given as parameters. 4693 4694=item B<EXAMPLE> 4695 4696 # Generate a Link to WWWdb:Index for the current session and db 4697 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4698 "Main-Index"); 4699 4700=item B<SEE ALSO> 4701 4702=back 4703 4704=cut 4705 4706 4707# --- Wrapper for val, to read single-entries of the config-file ----------- 4708 sub MyVal($$;$) # ConfigFile 4709{ 4710 my ($cSectionPI, $cEntryPI, $cDefaultPI) = @_; 4711 4712 my $cResult = defined($cDefaultPI)? $cDefaultPI: ""; 4713 4714 if (defined($oConfPoolGL)) 4715 { 4716 my $cResultConfigPool = 4717 $oConfPoolGL->getValue($cSectionPI, $cEntryPI); 4718 4719 $cResult = $cResultConfigPool 4720 if (defined $cResultConfigPool); 4721 4722 } 4723 4724 return $cResult; 4725} 4726 4727 4728 4729=head2 MySetVal - Set an entry, defined in the config-file 4730 4731=over 2 4732 4733=item B<DESCRIPTION> 4734 4735FIXME: add docs 4736 4737 - HTTP-link: http://<host> 4738 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4739 4740=item B<SYNOPSIS> 4741 4742 $hppt_ref = ResolveRefField($ref_field, $label); 4743 4744=item B<RETURN VALUE> 4745 4746 A correct HTML-Reference for the values, given as parameters. 4747 4748=item B<EXAMPLE> 4749 4750 # Generate a Link to WWWdb:Index for the current session and db 4751 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4752 "Main-Index"); 4753 4754=item B<SEE ALSO> 4755 4756=back 4757 4758=cut 4759 4760# --- Wrapper for val, to read single-entries of the config-file ----------- 4761 sub MySetVal($$@) # ConfigFile 4762{ 4763 my $cSectionPI = shift; 4764 my $cEntryPI = shift; 4765 my @pValuePI = @_; 4766 4767 if (defined($oConfPoolGL)) 4768 { 4769 $oConfPoolGL->setValue($cSectionPI, $cEntryPI, @pValuePI); 4770 } 4771} 4772 4773 4774 4775# --- Wrapper for val, to read list-entries of the config-file ------------- 4776sub MyListVal($$;$) # ConfigFile 4777{ 4778 my ($cSectionPI, $cEntryPI, $cDefaultPI) = @_; 4779 4780 my $cResult; 4781 my @lResult = (); 4782 4783 if (defined($oConfPoolGL)) 4784 { 4785 my $cResultConfigPool = 4786 $oConfPoolGL->getValue($cSectionPI, $cEntryPI); 4787 4788 4789 @lResult = split "\n", $cResultConfigPool; 4790 } 4791 4792 return @lResult; 4793} 4794 4795=head2 GetSelRadioLabel - Get the label from a Select-Field or Radio-Box 4796 4797=over 2 4798 4799=item B<DESCRIPTION> 4800 4801 This function returns the value or values of an Selectbox or radiofield. 4802 4803=item B<SYNOPSIS> 4804 4805 $label = ResolveRefField($field[, $value]); 4806 4807=item B<RETURN VALUE> 4808 4809 If only the fieldname is passed, then the whole field/label-list 4810 is returned. If a valid value is passed too, then the corresponding 4811 label will be returned. 4812 4813=item B<EXAMPLE> 4814 4815 # Get the Label for the "status"-field 4816 $cLabel = &GetSelRadioLabel("status", $iStatus); 4817 4818=item B<SEE ALSO> 4819 4820=back 4821 4822=cut 4823 4824sub GetSelRadioLabel($;$) 4825{ 4826 my $cFieldNamePI = shift; 4827 my $cValuePI = shift; 4828 4829 4830 4831 unless (defined $hSelectCacheMGL{$cFieldNamePI}) 4832 { 4833 my @lListValues; 4834 my %hLabels; 4835 my @lResult = &GetSelectboxValues($cFieldNamePI); 4836 4837 @lListValues = @{$lResult[0]}; 4838 %hLabels = %{$lResult[1]}; 4839 4840 $hSelectCacheMGL{$cFieldNamePI} = \%hLabels; 4841 } 4842 4843 if(defined $cValuePI) 4844 { 4845 return $hSelectCacheMGL{$cFieldNamePI}->{$cValuePI}; 4846 } 4847 else 4848 { 4849 return $hSelectCacheMGL{$cFieldNamePI}; 4850 } 4851} 4852 4853 4854=head2 Redirect - redirect the browser to another HTML-page 4855 4856=over 2 4857 4858=item B<DESCRIPTION> 4859 4860FIXME: add docs 4861 4862 - HTTP-link: http://<host> 4863 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4864 4865=item B<SYNOPSIS> 4866 4867 $hppt_ref = ResolveRefField($ref_field, $label); 4868 4869=item B<RETURN VALUE> 4870 4871 A correct HTML-Reference for the values, given as parameters. 4872 4873=item B<EXAMPLE> 4874 4875 # Generate a Link to WWWdb:Index for the current session and db 4876 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4877 "Main-Index"); 4878 4879=item B<SEE ALSO> 4880 4881=back 4882 4883=cut 4884 4885 sub Redirect($$) # HTML 4886{ 4887 my ($cSessionIdPI, $cConfigFilePI) = @_; 4888 4889 $oFormMGL = undef; 4890 4891 printf STDERR ("REDIRECT TO %s\n", 4892 &CreateReference($cSessionIdPI, $cConfigFilePI)) 4893 if &GetAttr("DebugLvl") > 2; 4894 4895 print redirect(&CreateReference($cSessionIdPI, $cConfigFilePI)) 4896 if &GetAttr("DebugLvl") < 10; 4897 4898 $iCacheTimeoutMGL = 0; 4899 4900 &MyExit(); 4901} 4902 4903 4904 4905 4906 4907=head2 CreateReference - makes an internal WWWdb-HTML-reference 4908 4909=over 2 4910 4911=item B<DESCRIPTION> 4912 4913FIXME: add docs 4914 4915 - HTTP-link: http://<host> 4916 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4917 4918=item B<SYNOPSIS> 4919 4920 $hppt_ref = ResolveRefField($ref_field, $label); 4921 4922=item B<RETURN VALUE> 4923 4924 A correct HTML-Reference for the values, given as parameters. 4925 4926=item B<EXAMPLE> 4927 4928 # Generate a Link to WWWdb:Index for the current session and db 4929 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4930 "Main-Index"); 4931 4932=item B<SEE ALSO> 4933 4934=back 4935 4936=cut 4937 4938 4939sub CreateReference($$) # HTML 4940{ 4941 my ($cSessionIdPI, $cConfigFilePI) = @_; 4942 4943 my $cResult; 4944 4945 # FIXME: use $ENV{"SERVER_PROTOCOL"} 4946 4947 $cResult = sprintf("http%s://%s/%s%s/%s/%s", 4948 &UnTaint($ENV{"HTTPS"})? "s": "", 4949 &GetAttr("HostName"), 4950 (&GetAttr("WWWdbDomain") eq "NULL"? 4951 "": 4952 &GetAttr("WWWdbDomain") . "/"), 4953 $cSessionIdPI, 4954 &GetAttr("DbDriver"), 4955 $cConfigFilePI); 4956 4957 return $cResult; 4958 4959} 4960 4961 4962 4963 4964 4965=head2 ResolveRefField - Resolve a Reference of an wwwdb_object 4966 4967=over 2 4968 4969=item B<DESCRIPTION> 4970 4971 Resolve a Reference of an wwwdb_object to a correct HTTP-Url. 4972 This Reference can have one of the following forms: 4973 4974 - HTTP-link: http://<host> 4975 - WWWdb-link: wwwdb://<Config-file>[;<Par>=<Value> ...] 4976 4977=item B<SYNOPSIS> 4978 4979 $hppt_ref = &ResolveRefField($ref_field, $label); 4980 4981=item B<RETURN VALUE> 4982 4983 A correct HTML-Reference for the values, given as parameters. 4984 4985=item B<EXAMPLE> 4986 4987 # Generate a Link to WWWdb:Index for the current session and db 4988 $hppt_ref = ResolveRefField("wwwdb://WWWdb:Index;Lang=de", 4989 "Main-Index"); 4990 4991=item B<SEE ALSO> 4992 4993=back 4994 4995=cut 4996 4997 sub ResolveRefField($$) # HTML 4998{ 4999 my $cRefFieldPI = shift; 5000 my $cLabelPI = shift; 5001 my $cResult; 5002 5003 $cResult = ""; 5004 5005 # WWWdb-Link (wwwdb://xxx) 5006 if($cRefFieldPI =~ "wwwdb://(.*)") 5007 { 5008 $cResult = a({href => &CreateReference 5009 (&GetAttr("SessionId"), $1)}, 5010 &EncodeHtml(i18n($cLabelPI))); 5011 } 5012 # normal http-Link 5013 elsif($cRefFieldPI =~ "https?://.*") 5014 { 5015 $cResult = a({href => $cRefFieldPI, 5016 target => "_wwwdb_new"}, 5017 &EncodeHtml(i18n($cLabelPI))); 5018 } 5019 # mail-reference 5020 elsif($cRefFieldPI =~ "mailto:.*") 5021 { 5022 $cResult = a({href => $cRefFieldPI}, 5023 &EncodeHtml(i18n($cLabelPI))); 5024 } 5025 # file-reference 5026 elsif($cRefFieldPI =~ "file:.*") 5027 { 5028 $cResult = a({href => $cRefFieldPI}, 5029 &EncodeHtml(i18n($cLabelPI))); 5030 } 5031 # Anything else as Text 5032 else 5033 { 5034 $cResult = b(&EncodeHtml(i18n($cRefFieldPI))); 5035 } 5036 5037 return $cResult; 5038} 5039 5040# --- Include a image -------------------------------------------------- 5041sub GenImage($;$$) 5042{ 5043 my $cSrcPI = shift; 5044 my $cAltPI = shift; 5045 my $cBorderPI = shift; 5046 5047 my $cResult = ""; 5048 my $cExt = undef; 5049 my $cSrc = ("/" . 5050 &GetAttr("BaseDir") . 5051 "/lib/" . 5052 $cSrcPI); 5053 5054 foreach ("", ".jpg", ".png", ".gif", ".JPG", ".PNG", ".GIF") 5055 { 5056 $cExt = $_; 5057 5058 print STDERR "GRAFIK: $cSrc$_\n"; 5059 5060 last 5061 if -f "$cSrc$_"; 5062 5063 $cExt = undef; 5064 } 5065 5066 if (defined $cExt) 5067 { 5068 if (defined $cAltPI) 5069 { 5070 $cResult = img({SRC => ("/" . 5071 &GetAttr("ScriptName") . 5072 "/lib/" . 5073 $cSrcPI . 5074 $cExt), 5075 ALT => $cAltPI, 5076 BORDER => $cBorderPI}); 5077 } 5078 else 5079 { 5080 $cResult =("/" . 5081 &GetAttr("ScriptName") . 5082 "/lib/" . 5083 $cSrcPI . 5084 $cExt); 5085 } 5086 } 5087 else 5088 { 5089 $cResult = ""; 5090 } 5091 5092 return $cResult; 5093 5094} 5095 5096# --- Interface for internationalisation ------------------------------- 5097{ 5098sub i18n($) 5099{ 5100 my $cMessage = shift; 5101 5102 my $cResult; 5103 5104 $cResult = $hMessagesGL{$cMessage} || $cMessage; 5105 5106 printf STDERR ("i18n(%s) => '%s'\n", 5107 $cMessage, 5108 $cResult) 5109 if &GetAttr("DebugLvl") > 3; 5110 5111 # This is for untranslated ones 5112 if($cResult =~ /^FIXME /) 5113 { 5114 $cResult =~ s/FIXME //; 5115 5116 $cResult = "[$cResult]" 5117 if &GetAttr("DebugLvl") > 9; 5118 } 5119 5120 $cResult = "($cResult)" 5121 if (&GetAttr("DebugLvl") > 9); 5122 5123 5124 return $cResult; 5125} 5126} 5127 5128 5129=head2 GetField - Get value of a Field in the HTML-Form 5130 5131=over 2 5132 5133=item B<DESCRIPTION> 5134 5135 Gets the current value of the field $field_name in the html-form and 5136 returns it. 5137 5138=item B<SYNOPSIS> 5139 5140 GetField (field_name) 5141 5142=item B<RETURN VALUE> 5143 5144 A string, containig the value of the input-field representing the 5145 field in the html-form. If the field-name does not exist, 5146 the function returns an empty string "". 5147 5148=item B<EXAMPLE> 5149 5150 # get the customer-id (custnum) 5151 $iCustNumber = &WWWDb::GetField("custnum"); 5152 5153=item B<SEE ALSO> 5154 5155 SetField 5156 5157=back 5158 5159=cut 5160 5161# ------------------------------------------------------------------------------ 5162sub GetField($) # Db-Record 5163{ 5164 my $cFieldNamePI = shift; 5165 5166 my $cResult = &MyParam("Fld$cFieldNamePI"); 5167 5168 print STDERR ">> GetField($cFieldNamePI)\n" 5169 if &GetAttr("DebugLvl"); 5170 5171 print STDERR "<< GetField($cResult)\n" 5172 if &GetAttr("DebugLvl"); 5173 5174 return $cResult; 5175} 5176 5177 5178 5179 5180 5181 5182=head2 SetField - Sets the value of a HTML-field 5183 5184=over 2 5185 5186=item B<DESCRIPTION> 5187 5188 Sets the value of the field $field_name in the HTML-Form to the value 5189 $value. In CGI it is threated as a parameter and passed via POST, so 5190 you can use it in the next turn again. 5191 5192=item B<SYNOPSIS> 5193 5194 SetField (field_name, $value); 5195 5196=item B<RETURN VALUE> 5197 5198 None. 5199 5200=item B<EXAMPLE> 5201 5202 # Set the Customer-id to 42 5203 &WWWdb::SetField("custnum", 42); 5204 5205=item B<SEE ALSO> 5206 5207 GetField 5208 5209=back 5210 5211=cut 5212 5213# ------------------------------------------------------------------------------ 5214 sub SetField($$) # Db-Record 5215{ 5216 my $cFieldNamePI = shift; 5217 my $cValuePI = shift; 5218 5219 print STDERR ">> SetField($cFieldNamePI, '$cValuePI')\n" 5220 if &GetAttr("DebugLvl"); 5221 5222 &MyParam("Fld$cFieldNamePI", $cValuePI); 5223 return; 5224} 5225 5226 5227 5228 5229 5230 5231 5232=head2 AddError - Add an error-message to the internal list 5233 5234=over 2 5235 5236=item B<DESCRIPTION> 5237 5238 Add an user-error-message to the internal error-message-list. This 5239 message is linked with the field $field_name. That means that 5240 this field is marked on the html-form and on the bottom of the form 5241 the $error_message is included in the list of errors. 5242 5243=item B<SYNOPSIS> 5244 5245 AddError ($field_name, $error_message); 5246 5247=item B<RETURN VALUE> 5248 5249 None. 5250 5251=item B<EXAMPLE> 5252 5253 # The field custnum must be filled 5254 if (&GetField("custnum")) 5255{ 5256 &AddError("custnum", "Please enter a valid customer-number"); 5257} 5258 5259=back 5260 5261=cut 5262 5263#------------------------------------------------------------------------------- 5264 sub AddError($$) # Db-Record 5265{ 5266 my $cFieldNamePI = shift; 5267 my $cErrorTextPI = shift; 5268 5269 print STDERR ">> AddError($cFieldNamePI, $cErrorTextPI)\n" 5270 if &GetAttr("DebugLvl"); 5271 5272 $hFieldErrorsMGL{"Fld$cFieldNamePI"} = $cErrorTextPI; 5273 5274 return; 5275} 5276 5277 5278 5279 5280 5281=head2 DecodeHtml - decodes HTML-formatted entities to normal Text 5282 5283=over 2 5284 5285=item B<DESCRIPTION> 5286 5287 Decodes HTML-formatted entities to normal Text. This means that, when 5288 you have HTML-Entities like ü, but you want human-readable data, 5289 you have to convert it. This function does this conversion. 5290 5291 5292=item B<SYNOPSIS> 5293 5294 $decoded_text = DecodeHtml($encoded_text); 5295 5296=item B<RETURN VALUE> 5297 5298 The decoded text. 5299 5300=item B<EXAMPLE> 5301 5302 # We need a �-Sign 5303 $copyright_sign = DecodeHtml("©"); 5304 5305=item B<SEE ALSO> 5306 5307 EncodeHtml, SafeEncodeHtml 5308 5309=back 5310 5311=cut 5312 5313# ------------------------------------------------------------------------------ 5314 sub DecodeHtml($) # HTML 5315{ 5316 my @lMessagePI = @_; 5317 5318 print STDERR ">> DecodeHtml(@lMessagePI)\n" 5319 if &GetAttr("DebugLvl"); 5320 5321 for (@lMessagePI) 5322 { 5323 $_ = decode_entities($_); 5324 } 5325 5326 return (wantarray? @lMessagePI: $lMessagePI[0]); 5327 5328} 5329 5330 5331=head2 EncodeHtml - encode normal text, to be HTML-save 5332 5333=over 2 5334 5335=item B<DESCRIPTION> 5336 5337 EncodeHtml encodes normal text, to be HTML-save. When you do this, any 5338 characters, which have a special meaning or coding in HTML, will be translated into 5339 correct HTML-entities. So you can savely use special characters like umlauts 5340 without caring, if HTML can display them correctly. 5341 5342 B<NOTE>: This function does NOT decode the HTML-characters <, >, &, ; and \" 5343 5344=item B<SYNOPSIS> 5345 5346 $encoded_text = EncodeHtml($text_to_encode); 5347 5348=item B<RETURN VALUE> 5349 5350 The encoded text. 5351 5352=item B<EXAMPLE> 5353 5354 # ��� -> öäü 5355 $encoded_text = EncodeHtml("���"); 5356 5357=item B<SEE ALSO> 5358 5359 SafeEncodeHtml 5360 5361=back 5362 5363=cut 5364 5365# --- encode HTML-Entities, but preserve HTML-Tags (� -> ü) ---------------- 5366 sub EncodeHtml($) # HTML 5367{ 5368 my @lMessagePI = @_; 5369 5370 print STDERR ">> EncodeHtml(@lMessagePI)\n" 5371 if &GetAttr("DebugLvl"); 5372 5373 for (@lMessagePI) 5374 { 5375 $_ = encode_entities($_, "\200-\377"); 5376 } 5377 5378 return (wantarray? @lMessagePI: $lMessagePI[0]); 5379 5380} 5381 5382 5383 5384=head2 SafeEncodeHtml - extended encoding of HTML-Tags 5385 5386=over 2 5387 5388=item B<DESCRIPTION> 5389 5390 EncodeHtml encodes normal text, to be HTML-save. When you do this, any 5391 characters, which have a special meaning or coding in HTML, will be 5392 translated into correct HTML-entities. So you can savely use special 5393 characters like umlauts without caring, if HTML can display them 5394 correctly. So long this behaves as B<EncodeHtml>, but this function 5395 handles the HTML-characters <, >, &, ; and \" too. 5396 5397 You will need this function by example to secure user-input, which 5398 will be displayed later in HTML. Some bad guy could enter HTML-tags, 5399 which show things on your site, you want not to display. 5400 5401=item B<SYNOPSIS> 5402 5403 $encoded_text = SafeEncodeHtml($text_to_encode); 5404 5405=item B<RETURN VALUE> 5406 5407 The safe encoded text. 5408 5409=item B<EXAMPLE> 5410 5411 use CGI; 5412 5413# print input of user 5414print p(SafeEncodeHtml($input_from_user)); 5415 5416=item B<SEE ALSO> 5417 5418 SafeEncodeHtml 5419 5420=back 5421 5422=cut 5423 5424# --- encode HTML-Entities, including <>&;" (� -> ü) ----------------------- 5425 sub SafeEncodeHtml($) # HTML 5426{ 5427 my @lMessagePI = @_; 5428 5429 print STDERR ">> SafeEncodeHtml(@lMessagePI)\n" 5430 if &GetAttr("DebugLvl"); 5431 5432 for (@lMessagePI) 5433 { 5434 $_ = encode_entities($_); 5435 } 5436 5437 return (wantarray? @lMessagePI: $lMessagePI[0]); 5438 5439} 5440 5441 5442# --- Create a reference for Scan-Doc --------------------------------------- 5443sub CreRef($$$) 5444{ 5445 my $cPreTextPI = shift; 5446 my $cRefPI = shift; 5447 my $cPostTextPI = shift; 5448 5449 return ($cPreTextPI . 5450 &CreateReference(&GetAttr("SessionId"), $cRefPI) . 5451 $cPostTextPI); 5452} 5453 5454 5455# --- Scan HTML-Text and replace WWWdb-specific references ------------------ 5456sub ScanDoc($) 5457{ 5458 my $cText = shift; 5459 my $cAppl = &GetAttr("ScriptName"); 5460 5461 $cText =~ s!=\"?wwwdb://(.*?)\"?>!&CreRef("=", $1, ">")!gei; 5462 5463 $cText =~ s!src=[\"\']?/wwwdb/([^\"\'\s]+)[\"\']?\s*!SRC=\"/$cAppl/$1\" !gi; 5464 5465 return $cText; 5466} 5467 5468 5469 5470 5471 5472=head2 GetFieldTypeName - get the fieldtype-name of a given field 5473 5474=over 2 5475 5476=item B<DESCRIPTION> 5477 5478 This function returns the SQL-Fieldtype of the given field. 5479 This is a short text like "varchar", "integer", etc. 5480 5481=item B<SYNOPSIS> 5482 5483 $cust_type = GetFieldTypeName($field_name); 5484 5485=item B<RETURN VALUE> 5486 5487 The SQL-fieldtype or undef, if the field does not exist. 5488 5489=item B<EXAMPLE> 5490 5491 # Convert date fields 5492 if(&GetFieldTypeName($field) eq "date") 5493{ 5494 &ConvertData($record{$field}); 5495} 5496 5497=item B<SEE ALSO> 5498 5499 - 5500 5501=back 5502 5503=cut 5504 5505 5506# --- Get the field-type of the field ----------------------------------------- 5507sub GetFieldTypeName($) # Database 5508{ 5509 my $cFieldNamePI = shift; 5510 5511 my $cResult = undef; 5512 5513 print STDERR ">> GetFieldTypeName($cFieldNamePI)\n" 5514 if &GetAttr("DebugLvl"); 5515 5516 if (defined $hTableInfoMGL{$cFieldNamePI}) 5517 { 5518 $cResult = (defined $hTableInfoMGL{$cFieldNamePI}{"TYPE_NAME"}? 5519 $hTableInfoMGL{$cFieldNamePI}{"TYPE_NAME"}: 5520 undef); 5521 5522 } 5523 5524 print STDERR "<< GetFieldTypeName($cResult)\n" 5525 if &GetAttr("DebugLvl"); 5526 5527 return $cResult; 5528 5529} 5530 5531 5532=head2 GetObjectId - get the id of the corresponding navigation-object 5533 5534=over 2 5535 5536=item B<DESCRIPTION> 5537 5538 FIXME 5539 5540 This procedure checks the existence of a session-parameter and those 5541 value. If every thing is alright, the value 1 is returned. When the 5542 session-parameter is preceeded by a "!", the check is negated. 5543 5544=item B<SYNOPSIS> 5545 5546 $b_value = IsAttribOK($name_of_session_parameter); 5547 5548=item B<RETURN VALUE> 5549 5550 1 if the session-parameter exists, an has a value, else 0 (or vice 5551 versa if negated) 5552 5553=item B<EXAMPLE> 5554 5555# Check, if we are logged in 5556 $bLoggedInCorrectly = IsAttribOK("ActualLogin"); 5557 5558=item B<SEE ALSO> 5559 5560=back 5561 5562=cut 5563 5564 5565# --- Get the Object-Id of the current application -------------------------- 5566 sub GetObjectId () # Nav (Database) 5567{ 5568 my $iResult = 0; 5569 5570 my $cUrlParams = &GetAttr("UrlParams"); 5571 my @lUrlParams = split ";", $cUrlParams; 5572 my $cLinkKey; 5573 5574 # the url-param overloads the value of the form 5575 foreach (@lUrlParams) 5576 { 5577 5578 $iResult = $1 5579 if (/^cat=(\d+)/); 5580 } 5581 5582 5583 $cLinkKey = ("wwwdb://" . 5584 ($iResult? "WWWdb:Nav": &GetAttr("ConfigFile")) . 5585 ($cUrlParams? (";" . $cUrlParams): "")); 5586 5587 # get object-info 5588 $iResult = ($oDbSessionGL->SqlSelect 5589 ("SELECT 5590 id_object 5591 FROM 5592 wwwdb_object 5593 WHERE 5594 ref_link = ?", 5595 $cLinkKey))->[0]->[0]; 5596 5597 # we had no success ... lets try it without the url-parameters 5598 if (!$iResult) 5599 { 5600 5601 $cLinkKey = ("wwwdb://" . 5602 &GetAttr("ConfigFile")); 5603 5604 # get category-info 5605 $iResult = ($oDbSessionGL->SqlSelect 5606 ("SELECT 5607 id_object 5608 FROM 5609 wwwdb_object 5610 WHERE 5611 ref_link = ?", 5612 $cLinkKey))->[0]->[0]; 5613 } 5614 5615 return $iResult; 5616} 5617 5618# FIXME: implement GetCategoryId too 5619 5620=head2 IsAttribOK - check a navigation-attribute 5621 5622=over 2 5623 5624=item B<DESCRIPTION> 5625 5626 This procedure checks the existence of a session-parameter and those 5627 value. If every thing is alright, the value 1 is returned. When the 5628 session-parameter is preceeded by a "!", the check is negated. 5629 5630=item B<SYNOPSIS> 5631 5632 $b_value = IsAttribOK($name_of_session_parameter); 5633 5634=item B<RETURN VALUE> 5635 5636 1 if the session-parameter exists, an has a value, else 0 (or vice 5637 versa if negated) 5638 5639=item B<EXAMPLE> 5640 5641# Check, if we are logged in 5642 $bLoggedInCorrectly = IsAttribOK("ActualLogin"); 5643 5644=item B<SEE ALSO> 5645 5646=back 5647 5648=cut 5649 5650 5651# --- check if the expression $cAttribPI is true ---------------------------- 5652 sub IsAttribOK ($@) # Session-Id 5653{ 5654 my $cAttribPI = shift; 5655 my $iResult = 999; 5656 5657 my %hBuiltins = ("IsHidden" => 1, 5658 "IsSSL" => 1, 5659 @_); 5660 5661 my $cOp = ""; 5662 my $cAttr = $cAttribPI; 5663 printf STDERR "cAttrPI = '$cAttr'\n"; 5664 5665 # pre-substitute all matching builtins 5666 foreach (keys %hBuiltins) 5667 { 5668 printf STDERR $hBuiltins{$_}." <= $_\n"; 5669 $cAttr =~ s/$_/$hBuiltins{$_}/ge; 5670 } 5671 5672 # This application should be hidden in categories, etc 5673 printf STDERR "cAttr = '$cAttr'\n"; 5674 if($cAttr ne "" && defined $oSessionGL) 5675 { 5676 $cAttr =~ s/([A-Za-z_]+)/$oSessionGL->getState($1)?1:0/ge; 5677 $cAttr = '$iResult = (' . $cAttr . ')'; 5678 5679 $iResult = eval { 5680 eval $cAttr; 5681 printf STDERR "A: cAttr = '$cAttr' => '$iResult'\n"; 5682 return $iResult; 5683 }; 5684 5685 $iResult = -999 5686 if $@; 5687 5688 printf STDERR "B: cAttr = '$cAttr' => '$iResult'\n"; 5689 } 5690 else 5691 { 5692 $iResult = 1; 5693 } 5694 5695 printf STDERR "B: iResult = '$iResult'\n"; 5696 5697 return $iResult; 5698} 5699 5700 5701=head2 SQLSelectList - Get the SQL-SELECT-result as a list 5702 5703=over 2 5704 5705=item B<DESCRIPTION> 5706 5707 SQLSelectList executes the Statement, given as argument, and returns a 5708 list of all found records with the fields backslach and 5709 comma-separated (\\,). 5710 5711=item B<SYNOPSIS> 5712 5713 @result_list = SQLSelectList($sql_select_statement); 5714 5715=item B<RETURN VALUE> 5716 5717 A array, containing one elemen for each found record. Inside the 5718 record, all the fields are separated with commas. When used in a 5719 scalar-context, perl will return the number of selected rows. 5720 5721=item B<EXAMPLE> 5722 5723 # check if login for Joe User is ok 5724 if(&SQLSelectList("SELECT username 5725 FROM users 5726 WHERE username = 'joe user' AND 5727 password = '42'")) 5728{ 5729 print "ok, you are Joe User\n"; 5730} 5731 5732# print all users 5733foreach (&SQLSelectList("SELECT username FROM users")) 5734{ 5735 print "$_\n"; 5736} 5737 5738=item B<SEE ALSO> 5739 5740 SQLDo 5741 5742=back 5743 5744=cut 5745 5746 5747# --- Execute the SQL-Select-statement and return the result as a list --------- 5748 sub SQLSelectList ($) # Database 5749{ 5750 my $cSelectCmdPI = shift; 5751 5752 my $cRecord; 5753 my $cResult; 5754 my $pStmtHdl; 5755 my $phRecord; 5756 my @lResult; 5757 5758 print STDERR ">> SQLSelectList($cSelectCmdPI)\n" 5759 if &GetAttr("DebugLvl"); 5760 5761 return undef 5762 if(!defined $pDbHdlMGL); 5763 5764 $pStmtHdl = $pDbHdlMGL->prepare($cSelectCmdPI); 5765 $pStmtHdl->execute(); 5766 5767 if($pStmtHdl->err()) 5768 { 5769 &MyDie(sprintf(i18n("Database Error occured during %s!") . "<BR>" . 5770 i18n(" SQL-Error: (%d) %s") . "<BR>" . 5771 i18n(" Statement: %s") . "<BR>", 5772 "SQLSelectList", 5773 $pStmtHdl->err, 5774 $pStmtHdl->errstr, 5775 $cSelectCmdPI)); 5776 } 5777 5778 while ($cRecord = join "\\,", $pStmtHdl->fetchrow_array) 5779 { 5780 print STDERR "Select: $cRecord\n" 5781 if &GetAttr("DebugLvl"); 5782 5783 push @lResult, $cRecord; 5784 } 5785 5786 $pStmtHdl->finish; 5787 5788 print STDERR "<< SQLSelectList(@lResult)\n" 5789 if &GetAttr("DebugLvl"); 5790 5791 return @lResult; 5792 5793} 5794 5795 5796 5797=head2 SQLDo - executes the given SQL-statement 5798 5799=over 2 5800 5801=item B<DESCRIPTION> 5802 5803 SQLDo executes the Statement, given as argument, and returns the 5804 number of affected records 5805 5806=item B<SYNOPSIS> 5807 5808 $nr_of_records = SQLDo($sql_statement); 5809 5810=item B<RETURN VALUE> 5811 5812 The number of Rows affected 5813# FIXME: What comes if an error is detected 5814 5815=item B<EXAMPLE> 5816 5817 # create a login for Joe User 5818 $nr_fo_records = &SQLDo("INSERT INTO username (username, password) 5819 VALUES ('joe user', '42')"); 5820 5821=item B<SEE ALSO> 5822 5823 SQLSelectList 5824 5825=back 5826 5827=cut 5828 5829 5830# --- Execute the SQL-Select-statement and return the result as a list --------- 5831 sub SQLDo ($) # Database 5832{ 5833 my $cSelectCmdPI = shift; 5834 5835 my $cRecord; 5836 my $cResult; 5837 my $pStmtHdl; 5838 my $phRecord; 5839 5840 print STDERR ">> SQLDo($cSelectCmdPI)\n" 5841 if &GetAttr("DebugLvl"); 5842 5843 $pStmtHdl = $pDbHdlMGL->prepare($cSelectCmdPI); 5844 $cResult = $pStmtHdl->execute(); 5845 5846 if($pStmtHdl->err()) 5847 { 5848 &MyDie(sprintf(i18n("Database Error occured during %s!") . "<BR>" . 5849 i18n(" SQL-Error: (%d) %s") . "<BR>" . 5850 i18n(" Statement: %s") . "<BR>", 5851 "SQLDo", 5852 $pStmtHdl->err, 5853 $pStmtHdl->errstr, 5854 $cSelectCmdPI)); 5855 } 5856 5857 $pStmtHdl->finish; 5858 5859 print STDERR "<< SQLDo($cResult)\n" 5860 if &GetAttr("DebugLvl"); 5861 5862 return $cResult; 5863 5864} 5865 5866 5867 5868=head2 GetAttr - Get some internal WWWdb-attributes 5869 5870=over 2 5871 5872=item B<DESCRIPTION> 5873 5874 GetAttr gets the values of some WWWdb-attributes: 5875 5876 - LastBtn 5877 - State 5878 - RecordOk 5879 - ScriptName 5880 - HostName 5881 - BaseDir 5882 - DbDriver 5883 - ConfigPath 5884 - ConfigFile 5885 - SessionId 5886 - UrlParams 5887 - LogfileName 5888 - HTMLfileName 5889 - RecIdField 5890 - RecId 5891 5892 5893=item B<SYNOPSIS> 5894 5895 $value = GetAttr($attribute_name); 5896 5897=item B<RETURN VALUE> 5898 5899 The Value of the selected Attribute 5900 5901=item B<EXAMPLE> 5902 5903 # Get the Driver of the Database 5904 $db_driver = &GetAttr("DbDriver"); 5905 5906=item B<SEE ALSO> 5907 5908=back 5909 5910=cut 5911 5912 5913# --- Execute the SQL-Select-statement and return the result as a list --------- 5914sub GetAttr ($) # CGI ENV ConfigFile 5915{ 5916 my $cAttrTypePI = shift; 5917 my $cResult = undef; 5918 5919 switch: for ($cAttrTypePI) 5920 { 5921 /^LastBtn$/ && do { 5922 $cResult = &MyParam("WWWdbLastBtn"); 5923 last switch; 5924 }; 5925 5926 /^Lang$/ && do { 5927 $cResult = &MyUserVal('WWWdb', 'Lang', 'en'); 5928 last switch; 5929 }; 5930 5931 /^BaseLang$/ && do { 5932 $cResult = &MyVal('WWWdb', 'Lang', 'en'); 5933 last switch; 5934 }; 5935 5936 /^State$/ && do { 5937 $cResult = &MyParam("WWWdbState"); 5938 last switch; 5939 }; 5940 5941 /^RecordOk$/ && do { 5942 &CheckRecord(); 5943 5944 $cResult = (%hFieldErrorsMGL)? "": "Yes"; 5945 last switch; 5946 }; 5947 5948 /^ScriptName$/ && do { 5949 5950 # same as basename 5951 ($cResult = &GetAttr("BaseDir")) =~ s{.*/}{}; 5952 last switch; 5953 }; 5954 5955 /^WWWdbDomain$/ && do { 5956 5957 $cResult = (&UnTaint($ENV{"WWWDB_DOMAIN"})? 5958 &UnTaint($ENV{"WWWDB_DOMAIN"}): 5959 "WWWdb"); 5960 5961 last switch; 5962 }; 5963 5964 /^HostName$/ && do { 5965 $cResult = &MyVal("WWWdb", "Hostname", &UnTaint($ENV{"HTTP_HOST"})); 5966 last switch; 5967 }; 5968 5969 /^DebugLvl$/ && do { 5970 $cResult = &MyUserVal('Debug', 'Level', '10') && 5971 !!&UnTaint($ENV{"HTTP_PRAGMA"}); 5972 last switch; 5973 }; 5974 5975 /^BaseDir$/ && do { 5976 $cResult = (&UnTaint($ENV{"WWWDB_BASE_PATH"})? 5977 &UnTaint($ENV{"WWWDB_BASE_PATH"}): 5978 &UnTaint($ENV{"DOCUMENT_ROOT"}) . "/WWWdb"); 5979 5980 last switch; 5981 }; 5982 5983 /^DbDriver$/ && do { 5984 $cResult = (&UnTaint($ENV{"WWWDB_DATABASE"})? 5985 &UnTaint($ENV{"WWWDB_DATABASE"}): 5986 "Default"); 5987 last switch; 5988 }; 5989 5990 /^DbHandle$/ && do { 5991 $cResult = $pDbHdlMGL; 5992 last switch; 5993 }; 5994 5995 /^ConfigPath$/ && do { 5996 $cResult = (&UnTaint($ENV{"WWWDB_CONFIG_FILE"})? 5997 &UnTaint($ENV{"WWWDB_CONFIG_FILE"}): 5998 "WWWdb/Index"); 5999 last switch; 6000 }; 6001 6002 /^ConfigFile$/ && do { 6003 ($cResult = (&UnTaint($ENV{"WWWDB_CONFIG_FILE"})? 6004 &UnTaint($ENV{"WWWDB_CONFIG_FILE"}): 6005 "WWWdb:Index")) =~ tr !/!:!; 6006 last switch; 6007 }; 6008 6009 /^SessionId$/ && do { 6010 $cResult = &UnTaint($ENV{"WWWDB_SESSION_ID"}); 6011 last switch; 6012 }; 6013 6014 /^UrlParams$/ && do { 6015 $cResult = &UnTaint($ENV{"WWWDB_PARAMS"}); 6016 last switch; 6017 }; 6018 6019 /^LogfileName$/ && do { 6020 $cResult = (&GetAttr("BaseDir") . 6021 "/tmp/" . 6022 &GetAttr("ScriptName") . 6023 ($iDevelopmentVersionMGL? 6024 "$<-$$.log": # uid-pid 6025 "$<.log")); 6026 last switch; 6027 }; 6028 6029 /^HTMLfileName$/ && do { 6030 $cResult = (&GetAttr("BaseDir") . 6031 "/tmp/" . 6032 &GetAttr("ScriptName") . 6033 "$<-$$.html"); # uid-pid 6034 last switch; 6035 }; 6036 6037 /^RecIdField$/ && do { 6038 $cResult = &MyVal("Data", "IdField", ""); 6039 last switch; 6040 }; 6041 6042 /^RecId$/ && do { 6043 my @lKeyFields = split /, /, &GetAttr("RecIdField"); 6044 6045 # scan multiple primary-keys 6046 foreach (@lKeyFields) 6047 { 6048 $_ = &GetField($_); 6049 } 6050 6051 $cResult = join ",", @lKeyFields; 6052 last switch; 6053 }; 6054 6055 /^ObjectId$/ && do { 6056 $cResult = &GetAttr("RecId"); 6057 last switch; 6058 }; 6059 /^AppId$/ && do { 6060 $cResult = md5_hex(&GetAttr("ConfigFile")); 6061 last switch; 6062 }; 6063 6064 assert($cAttrTypePI eq "defined") 6065 if &MyUserVal('Debug', 'Level', '0'); 6066 } 6067 6068 return $cResult; 6069 6070} 6071 6072 6073# --- At the moment this is only hiding tainted things, without 6074# security-checks 6075sub UnTaint($;$) 6076{ 6077 my $cUnTaintExprPI = shift || ""; 6078 my $cUnTaintRegexPI = shift || "^(.*)\$"; 6079 6080 if ($cUnTaintExprPI =~ m/$cUnTaintRegexPI/) 6081 { 6082 # now untainted but dangerous!!! 6083 return $1; 6084 } 6085 else 6086 { 6087 return $cUnTaintExprPI; 6088 } 6089} 6090 6091 6092 6093=head1 AUTHOR 6094 6095 Klaus Reger <K.Reger@wwwdb.org> 6096 6097 Get WWWdb at http://wwwdb.org 6098 6099=cut 6100 6101 6102# run, run, run ..... 6103&Main(); 6104 61051; 6106 6107 6108# ----------------------------------------------------------------------------- 6109# $Log: WWWdb.cgi,v $ 6110# Revision 1.49 2003/04/16 11:25:21 k_reger 6111# - Help now implemented using documents 6112# 6113# Revision 1.48 2003/04/11 13:32:35 k_reger 6114# - Localisation included directly in WWWdb 6115# 6116# Revision 1.47 2002/11/19 12:21:01 k_reger 6117# - added function GetSelectboxValues($) 6118# 6119# Revision 1.46 2002/11/18 13:58:30 k_reger 6120# - Support Target-DB 6121# 6122# Revision 1.45 2002/04/08 04:59:01 k_reger 6123# - SQL-correction for Interbase 6124# - Switch temp. to devel-Version 6125# 6126# Revision 1.44 2002/03/18 15:24:57 k_reger 6127# - prepare for 0.8.2 6128# 6129# Revision 1.43 2002/03/15 08:59:58 k_reger 6130# - Bugfix: Selectfields / radiofields now correctly translated 6131# - Enter triggers default-button 6132# 6133# Revision 1.42 2002/03/05 16:16:10 k_reger 6134# - no "use lib" 6135# - untaint all ENV-Variables (not really) 6136# - set caching off by default 6137# - set VERSION directly here 6138# 6139# Revision 1.41 2001/01/25 11:52:27 k_reger 6140# - Better date-scanning and printing 6141# - enhanced order mechanism 6142# 6143# Revision 1.40 2000/11/30 13:58:46 k_reger 6144# - design separated from function via HTML::Templates 6145# 6146# Revision 1.39 2000/11/28 16:04:58 k_reger 6147# - Extended Attributes like H1 ... H6, PRE, etc. 6148# - SSL-Support 6149# - Design done by HTML::Templates 6150# - Navigation-Elements separated 6151# - Support of perl-locales 6152# - Debug-info only after reload 6153# 6154# Revision 1.38 2000/11/17 11:53:01 k_reger 6155# - Show sub-categories of the upper categoriy too 6156# - New Attribs H1 ... H4 6157# - Replaced some constants 6158# 6159# Revision 1.37 2000/11/15 12:08:42 k_reger 6160# - BUGFIX: Sort-buttons work again now 6161# - https-link-support 6162# - Browser can force WWWdb to ignore caching 6163# 6164# Revision 1.36 2000/11/03 11:36:20 k_reger 6165# - prepared for 0.8.0 6166# 6167# Revision 1.33 2000/09/29 11:16:21 k_reger 6168# - BUGFIX: check if plugin is readable 6169# - BUGFIX: handle blanks in generated links 6170# - better HTML-Cache-handling 6171# - new operator <> (like !=) 6172# - empty values can now be selected with "" or '' 6173# - check ExtraFields too 6174# - added MustMatch.Errmsg for a clear description of the regexp 6175# - now you can set the link-color with the entries [GUI]->Link, [GUI]->ALink, [GUI]->VLink, 6176# - removed WWWdb-specific plugins here 6177# 6178# Revision 1.32 2000/09/21 07:21:05 k_reger 6179# - Better Handling of Hidden-fields 6180# - CGI::Debug 6181# - Multiple-scrolling-lists work now 6182# - User-defined Buttons are placed behind the standard-buttons 6183# 6184# Revision 1.1 2000/05/10 13:39:04 work 6185# Initial revision 6186# 6187# Revision 1.29 2000/03/30 13:50:20 klaus 6188# Checkpoint before Release 0.0.7 6189# 6190# Revision 1.28 2000/03/24 09:49:20 klaus 6191# Checkpoint 6192# 6193# Revision 1.1 2000/03/06 14:10:09 work 6194# Initial revision 6195# 6196# Revision 1.27 2000/02/24 11:27:04 klaus 6197# - Internationalization 6198# - New OO-Classes 6199# 6200# Revision 1.1 2000/02/09 09:50:44 work 6201# Initial revision 6202# 6203# Revision 1.26 2000/02/02 23:38:48 klaus 6204# Second preparing WWWdb for 0.0.6 6205# 6206# Revision 1.25 2000/02/02 21:38:43 klaus 6207# Preparing WWWdb for 0.0.6 6208# 6209# Revision 1.24 2000/01/10 15:38:14 klaus 6210# Html-Tables in OO now 6211# 6212# Revision 1.23 1999/12/22 13:02:53 klaus 6213# Last corrections before 0.0.5 6214# 6215# Revision 1.22 1999/12/21 17:55:40 klaus 6216# New features of WWWdb-0.0.5: 6217# System: 6218# New General form layout (FormHeader, Navigation, TableHeader, Application-area, 6219# TableFooter, FormFooter) 6220# New Plugin: PreDoAction 6221# New Plugins: FormHeader, TableHeader, TableFooter, FormFooter 6222# Navigation through hierarchy 6223# Navigation through search-words 6224# Default-session-id is now 0000000000000000 6225# File-hierarchy of configfiles is now possible: x/y/z => x:y:z 6226# Passing parameters via URL in the form URL;Param=Value 6227# New config-entries for simple field checking / converting: Mandatory, MustMatch,ToUpper, ToLower 6228# The navigation column is generated from database 6229# Query-fields can be attributed 6230# Different ways to select a record in the browse: Btn, Check, None (implies selection via link) 6231# Vertical alignment of single entries 6232# Generate WWWdb-References in Labels 6233# API: 6234# ResolveRefField - Resolve a WWWdb-Reference for HTML 6235# InternalFieldCheck - perform the default-checks for a field 6236# Get-Attr - Get WWWdb Attributes 6237# ConfigPath - the file-path of the config-file 6238# UrlParams - the params passed by the URL 6239# GetLastBtn - -deleted- 6240# Applications: 6241# Navigation in wwwdb via hierarchy or search-words 6242# Edit navigation-categories 6243# Edit navigation-objects 6244# Link category and object 6245# Edit docu-entries 6246# 6247# Revision 1.21 1999/12/06 10:44:26 klaus 6248# - implemented file-hierarchy 6249# 6250# Revision 1.20 1999/12/02 15:19:02 klaus 6251# - New General Table-Layout 6252# - If config-file is missing, we take Empty.rc 6253# - New Plugins: 6254# + PreDoAction 6255# + FormHeader, TableHeader, TableFooter, FormFooter 6256# - Generated menu-structure (from database) 6257# - Different way to select records in Qry-Mode 6258# - Default session-id is now 0000000000000000 6259# - a : in url generates a file hierarchy (x:y:z => x/y/z) 6260# - pass params via the url in the form url;param=value[;paramn=valuen] 6261# - API-function GetLastBtn deleted 6262# 6263# Revision 1.19 1999/11/23 15:43:09 klaus 6264# New lib-directory 6265# 6266# Revision 1.18 1999/11/22 09:13:13 klaus 6267# - Last bugfixes before 0.0.4 6268# 6269# Revision 1.17 1999/11/19 14:29:10 klaus 6270# - Last corrections before 0.0.4 6271# 6272# Revision 1.16 1999/11/19 12:42:35 klaus 6273# - Corrections after installation on pc01 6274# 6275# Revision 1.15 1999/11/18 15:00:51 klaus 6276# - New Help-Interface 6277# - Login now crypted 6278# 6279# Revision 1.14 1999/11/15 13:52:36 klaus 6280# - HTML-output buffered 6281# - WWWdb_(Pre|Post).(rc|pl) 6282# - own tmp-directory 6283# - little customizations for qry-mode 6284# - enhancement of debug-trace-utilities 6285# - API: GetAttr() 6286# 6287# Revision 1.13 1999/11/11 14:15:48 klaus 6288# Corrections after internal installation 6289# 6290# Revision 1.12 1999/11/11 13:22:49 klaus 6291# Snapshot for internal installation 6292# 6293# Revision 1.11 1999/11/02 12:01:58 klaus 6294# Check-in to store actual state 6295# 6296# Revision 1.10 1999/10/22 11:06:06 klaus 6297# - Corrections of the data-conversion between Db and Html-Form 6298# 6299# Revision 1.9 1999/10/21 13:35:05 klaus 6300# - Select and Radio-Fields can now be filled with SQL 6301# - WWWdb is now "-w"-proof 6302# - Database-Errors are now shown uniquely 6303# 6304# Revision 1.8 1999/10/20 13:01:34 klaus 6305# Version 1.0.3 6306# - Getting field-type-information 6307# - Plugins to convert DB-data to Form-data and vice versa 6308# - New API-functions 6309# $current_state = GetState(); 6310# $cust_type = GetFieldTypeName($field_name); 6311# 6312# BUGFIX: 6313# -kfm, lynx and w3m seem to work now 6314# 6315# Revision 1.7 1999/10/08 13:48:09 klaus 6316# - Selection-Boxes and radio-fields now can have labels 6317# - plugins: API-Documentation 6318# - Perl-makefile integrated 6319# 6320# Revision 1.6 1999/10/07 13:56:20 klaus 6321# - Security-Bugfix: HTML-Entities decoded 6322# - Internal state perfixed with WWWdb 6323# - Adding file README.application 6324# - Enhancements of index.html 6325# 6326# Revision 1.5 1999/10/06 08:42:13 klaus 6327# Checkpoint before copying to WWW-server 6328# 6329# Revision 1.4 1999/10/06 06:49:19 klaus 6330# Sync 06.10.99 6331# 6332# Revision 1.3 1999/10/06 06:21:08 klaus 6333# Sync with KR's work at home. 6334# 6335# Revision 1.2 1999/09/28 13:12:53 klaus 6336# Bugfixes 6337# 6338# Revision 1.1.1.1 1999/09/27 08:50:26 klaus 6339# Integration in CVS 6340# 6341# Revision 1.1.1.1 1999/09/27 08:09:51 klaus 6342# Imported using tkCVS 6343# 6344# Revision 1.10 1999/09/21 08:34:33 klaus 6345# - Anzeige von Fehlern in der Konfigurations-Datei 6346# - Update/Query-Felder getrennt konfigurierbar 6347# - Neue Attribute: 6348# Align, BgColor, NoWrap, Big, Blink, Bold, Italic, Small 6349# Font, Disabled, Readonly, Tabindex, Title 6350# - Neue Input-Felder: 6351# Password, Area, Hidden, Radio, Checkbutton 6352# - Position kann nun auch als Offset angegeben werden 6353# 6354# Revision 1.9 1999/09/17 14:07:26 klaus 6355# - Konfigurationsdatei zur Steuerung 6356# + Datenbank-Verbindung 6357# + Allgemeines Tabellenlayout 6358# + Label 6359# + Textfelder 6360# + Select-Buttons 6361# 6362# Revision 1.8 1999/09/13 14:10:04 klaus 6363# - Hilfs-informationen 6364# - letzte Version vor Verallgemeinerung 6365# 6366# Revision 1.7 1999/09/07 09:33:40 klaus 6367# - Funktionen zum Browsen der Daten 6368# - Normierung der Telefon-Nummern 6369# - Assertions eingebaut 6370# - Fehler-Meldungen über OK-Form 6371# 6372# Revision 1.6 1999/09/02 12:43:22 klaus 6373# - Farb- und Font Korrekturen 6374# -> Dies ist die erste freigegebene Alpha-Version 6375# 6376# Revision 1.5 1999/09/01 13:55:40 klaus 6377# - Korrekte Fehlerbehandlung 6378# - Konsistente Verwaltung der Übergabe-Parameter 6379# 6380# Revision 1.4 1999/09/01 07:20:50 klaus 6381# - Folgende DB-Funktionen eingebaut: 6382# + Änderung 6383# + Löschung 6384# - Oracle-Anbindung läuft nun korrekt 6385# - DB-Meldungen als OK-Forms 6386# 6387# Revision 1.3 1999/08/31 10:46:13 klaus 6388# Nun funktionieren folgende DB-Funktionen: 6389# - Neuanlage 6390# - Suche 6391# - Auswahl von Sätzen 6392# 6393# Revision 1.2 1999/08/26 12:20:40 klaus 6394# Aller unnötiger HTML-Code entfernt 6395# 6396# Revision 1.1 1999/08/25 07:33:05 klaus 6397# Initial revision 6398# 6399# 6400# ----------------------------------------------------------------------------- 6401