#!perl -w # # DBIx::Web - Active Web Database Layer # # makarow at mail.com, started 2003-09-16 # # Future ToDo: # - !!! ??? review, code review # - record references finder via 'wikn://', 'key://', bracket notation # - root hierarchical record functionality: -ridRoot # - calendar views: type and start/end time; start sub{}, entry sub{}, periodical rec. # - mail-in interface - records and message browser source # - logfile reading interface - message browser source # - acknowledgements feature - message browser implementation # - replication feature - distributing data # - 'recRead' alike calls may return an objects, knows metadata # - remake in three tiers: database with triggers, web interface, communicator # # Problems - Think: # - strDiff() breaks hyperlinks # - key:// hyperlinks valid only when -cgibus or table//key syntax # - table operation trigger instead of -cgiRun0A: should be included within each trigger and duplicated within actions and user interface # # -unflt/uglist, -ugflt/uglist/ugroups, -usernt/user/uglist, -userln/user/uglist, -udisp/udisp, -ugadd/ugroups/uglist # # ui: -unflt, -udisp # # pi: -ugflt, -usernt, -userln, -ugadd # # pc: uglist, user, ugroups, udisp # - store for users preferences, homepages, notes, etc. # # Limitation Issues: # - html page scrolling with menu bar # # no simple means # - innice htmlML() selection: _frmName.value=_form.value ? _form.value : ''; # # ms-help://MS.MSDNQTR.2005JAN.1033/DHTML/workshop/samples/author/dhtml/refs/oncontextmenu.htm # - dbmSeek() -key=>{[{}]} syntax of cgiForm(recQBF)/cgiQKey # # dbm not used at all, it seems # # ToDo: # - utf8 if $] <5.008; cptran() & Encode module # - osCmd xcopy replace # - osCmd cacls may buzz sometimes somewhy # - w32umail() slow # CMDB / Service Desk: # - cmdb-e: service graph view # - cmdb: process - define hierarchy in cmdb? # - cmdb: graphics (of workload (of personal)) # - cmdb-s: update vtime/-rvcVerWhen, recprc in old records # # Done: # 2008-04-24 starting 0.75 version package DBIx::Web; require 5.000; use strict; use UNIVERSAL; use POSIX; use Fcntl qw(:DEFAULT :flock :seek :mode); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD $SELF $CACHE $LNG $IMG); $VERSION= '0.74'; $SELF =undef; # current object pointer $CACHE ={}; # cache for pointers to subobjects *isa = \&UNIVERSAL::isa; isa('',''); # isa function my $RISM0 ='/'; # record identification separation mark 0 my $RISM1 ='//'; # record identification table/id seperator # (-idsplit; consider -recInsID, -rfdName) my $RISM2 ='.rfd'; # record identification end special mark my $NLEN =14; # length to pad left numbers in indexes my $LIMRS =512; # limit of result set my $LIMLB =8 *$LIMRS; # limit of result set for listboxes my $KSORD ='-aall'; # default key sequental order my $HS =';'; # hyperlink parameters separation style '&' my $TW32 =($^O eq 'MSWin32') && (*Win32::GetTickCount{CODE}) && eval{Win32::GetTickCount()}; # see also '-tn' definitions if ($ENV{MOD_PERL}) { eval('use Apache qw(exit);'); } $LNG ={ '' =>undef ,-die =>sub{CORE::die(@_)} ,-warn =>sub{CORE::warn(@_)} ,'' =>{'' =>['', ''] ,-lang =>['en', ''] ,-charset =>['windows-1252',''] ,-style =>['Style', 'HTML/XML style decoration URL'] ,'-frame=set' =>['Frameset', 'Frameset form'] ,-affected =>['affected', 'rows affected'] ,-fetched =>['fetched', 'rows fetched'] ,-key =>['Key', 'Key of the record'] ,-wkey =>['Lock key', 'Key to lock update of the record'] ,-wikn =>['Name', 'May contain name of the record'] ,-ridRef =>['References','References to another records'] ,-rvcActPtr =>['Versioning','When record is been saving, its old version record is to be created pointing to it'] ,-rvcChgState =>['Changing', 'Record is under change without versioning, files may be attached'] ,-rvcCkoState =>['Check out', 'Record is checked out, without versioning, files may be attached'] ,-rvcDelState =>['Deleted', 'Record is deleted logically'] ,-racWriter =>['Writers', 'Writers of the record'] ,-racReader =>['Readers', 'Readers of the reord'] ,-racActor =>['Actors', 'Actors of the record'] ,-racManager =>['Managers', 'Managers of the record'] ,-racPrincipal =>['Principals','Principals of the record'] ,-racUser =>['Users', 'Users of the record'] ,'Error' =>['Error', 'Error'] ,'rfaUplEmpty' =>['empty', 'Empty filehandle'] ,'recUpdAclStp' =>['', 'Record updation prohibited to you'] ,'recUpdVerStp' =>['', 'Editing record\'s version prohibited'] ,'recDelAclStp' =>['', 'Record deletion prohibited to you'] ,'recReadAclStp'=>['', 'Record reading prohibited to you'] ,'fldReqStp' =>['required', 'value required'] ,'fldChkStp' =>['constraint','constraint violated'] ,'home' =>['Home', 'Home screen'] ,'schpane' =>['Navigation','Navigation/Search pane'] ,'back' =>['<', 'Back screen'] ,'login' =>['Login', 'Login as personated user'] ,'frmCall' =>['Go', 'Goto/execute choise'] ,'frmCallOpn' =>['Open'] ,'frmCallNew' =>['Create for','Create new record to insert into'] ,'frmHelp' =>['Help', 'Help screen'] ,'frmErr' =>['Error', 'Error screen'] ,'frmName' =>['Form', 'Form choice'] ,'frmLso' =>['Selection', "Records selections, may overlap other query conditions specified, may be switched off by '--x' choices"] ,'frmLsoff' =>['------------x', 'Switch off selections below'] ,'frmLsc' =>['Ordering', 'Records ordering, may overlap other query conditions spacified'] ,'frmName1' =>['Create', 'Create new record with form choosen to insert into database'] ,'recNew' =>['Create', 'Create new record to insert into database'] ,'recRead' =>['Read', 'Read record from the database; escape edit mode discarding changes'] ,'recEdit' =>['Edit', 'Edit this record to update in the database'] ,'recPrint' =>['Print', 'Printable form'] ,'recXML' =>['XML', 'XML form'] ,'recHist' =>['History', 'History of changes form'] ,'recIns' =>['Insert', 'Insert this data into database as a new record'] ,'recUpd' =>['Save', 'Update this record or save data into database'] ,'recDel' =>['Delete', 'Delete this record in the database'] ,'recForm' =>['Form', 'Recheck this data on server'] ,'recList' =>['List', 'List records, execute query'] ,'recQBF' =>['Query', 'Specify records to be listed'] ,'recQBFReset' =>['Reset', 'Reset query conditions to default'] ,'-query' =>['Query', 'Data query specification'] ,'-qkeyord' =>['SEEK', 'Key seek relation'] ,'-qjoin' =>['JOIN', 'FROM database query clause addition to use for WHERE'] ,'-qwhere' =>['WHERE', 'WHERE database query clause'] ,'-qurole' =>['UROLE', 'Role of User'] ,'-quname' =>['UNAME', 'Name of User'] ,'-qftext' =>['FULL TEXT', 'Full-text search string'] ,'-qversion' =>['VERSIONS', 'Including old versions of records'] ,'-qorder' =>['ORDER BY', 'ORDER BY database query clause'] ,'-qlimit' =>['LIMIT', 'LIMIT database query clause'] ,'-qdisplay' =>['DISPLAY', 'Columns to display in list'] ,'-qurl' =>['URL', 'Query URL constructed, press \'Form\' to refresh'] ,'rfafolder' =>['Files', 'File Attachments'] ,'rfauplfld' =>['Upload', 'File to upload'] ,'rfaupdate' =>['+/-', 'Upload file, close or delete attachments selected'] ,'rfaopen' =>['...', 'Opened file attachments to be closed'] ,'rfaclose' =>['Close'] ,'rfadelm' =>['Delete', 'Mark file attachments to be deleted'] ,'ddlbopen' =>['...', 'Open values'] ,'ddlbopenl' =>['>', 'Open values recursion'] ,'ddlbsubmit' =>['Set', 'Assign value selected'] ,'ddlbreset' =>['c', 'Clear value'] ,'ddlbclose' =>['x', 'Close values'] ,'ddlbfind' =>['..', 'Find value in the list'] ,'tvmVersions' =>['All Versions', 'All records and their versions'] ,'tvmHistory' =>['All News', 'All news, updates, deletions'] ,'tvmReferences'=>['All References', 'All references to records'] ,'tvdIndex' =>['All Contents', 'Table of contents'] ,'tvdFTQuery' =>['All Files Find', 'Full-text query on files'] ,'-qftwhere' =>['FTQuery', 'Full-text query condition'] ,'-qftord' =>['FTOrder', 'Full-text search result set sort order'] ,'-qftlimit' =>['FTLimit', 'Full-text search result set limit'] ,'table' =>['Table', 'Table or recfile name'] ,'id' =>['ID', 'Record ID', 'id'] ,'ir' =>['IR', "Refered ID"] ,'idrm' =>['AboveID', "Record, above this, 'id' or 'table'//'id'"] ,'idpr' =>['PrevID', "Record, previous to this, 'id' or 'table'//'id'"] ,'hierarchy' =>['hierarchy'] ,'cuser' =>['Ins by', 'User, record inserted by'] ,'creator' =>['Ins by', 'User, record inserted by'] ,'ctime' =>['Ins time', 'Date and time, record inserted when'] ,'uuser' =>['Upd by', 'User, record updated by'] ,'updater' =>['Upd by', 'User, record updated by'] ,'utime' =>['Upd time', 'Date and time, record updated when'] ,'idnv' =>['Ver of', 'Actual record ID, points to the actual and fresh version'] ,'vtime' =>['Ver time', 'Date and time, version recorded when'] ,'status' =>['State', 'State of the record'] ,'todo' =>['todo'] ,'done' =>['done'] ,'deleted' =>['deleted'] ,'edit' =>['edit'] ,'chk-out' =>['chk-out'] ,'all' =>['all'] ,'auser' =>['Actor', 'Actor of the record, user name'] ,'actor' =>['Actor', 'Actor of the record, user name'] ,'arole' =>['Actors', 'Role of the actor of the record or additional actor user'] ,'actors' =>['Actors', 'Actors of the record, users and groups, comma delimited'] ,'puser' =>['Principal', 'Principal of the record, user name'] ,'principal' =>['Principal', 'Principal of the record, user name'] ,'prole' =>['Principals','Role of the principal of the record or additional principal user'] ,'principals' =>['Principals','Principals of the record, users and groups, comma delimited'] ,'manager' =>['Manager', 'Manager of the record, user name'] ,'muser' =>['Manager', 'Manager of the record, user name'] ,'mrole' =>['Managers', 'Role of the manager of the record, group or user'] ,'managers' =>['Managers', 'Managers of the record, users and groups, comma delimited'] ,'owner' =>['Owner', 'Owner of the record, user name'] ,'orole' =>['Owners', 'Role of the owner of the record or additional owner'] ,'owners' =>['Owners', 'Owners of the record, users and groups, comma delimited'] ,'user' =>['User', 'User of the record, user name'] ,'users' =>['Users', 'Users of the record, users and groups, comma delimited'] ,'author' =>['Author', 'Author of the record, user name'] ,'authors' =>['Authors', 'Authors of the record, comma delimited'] ,'rrole' =>['Readers', 'Readers of the record, group or role'] ,'readers' =>['Readers', 'Readers of the record, users and groups, comma delimited'] ,'mailto' =>['MailTo', 'Receipients of e-mail of the record status current, comma delimited'] ,'record' =>['Record', 'Class/type of the record described by'] ,'object' =>['Object', 'Object of the record described by'] ,'project' =>['Project', 'Project, related to the record'] ,'cost' =>['Cost', 'Cost of the record described by'] ,'doctype' =>['Doctype', 'Type of the document contained'] ,'subject' =>['Subject', 'Subject, Title, Brief description'] ,'comment' =>['Comment', "Comment text or HTML. Special URL protocols: 'urlh://' (this host), 'urlr://' (this application), 'urlf://' (file attachments), 'key://' (record id or table${RISM1}id), 'wikn://' (wikiname). Bracket URL notations: [[xxx://...]], [[xxx://...][label]], [[xxx://...|label]]. Starting text with condition may be used for embedded query"] ,'cargo' =>['Cargo', 'Additional data'] } ,'ru' =>{'' =>['', ''] ,-lang =>['ru-RU', ''] ,-charset =>['windows-1251',''] ,-style =>['', ' HTML/XML'] ,'-frame=set' =>['',' '] ,-affected =>['', ' '] ,-fetched =>['', ' '] ,-key =>['', ' '] ,-wkey =>[' .', ' '] ,-wikn =>['', ' '] ,-ridRef =>['', ' '] ,-rvcActPtr =>['',' , , '] ,-rvcChgState =>['', ' , '] ,-rvcCkoState =>['', ' , , '] ,-rvcDelState =>['', ' '] ,-racWriter =>['', ' '] ,-racReader =>['', ' '] ,-racActor =>['',' '] ,-racManager =>['', ' '] ,-racPrincipal =>['',' '] ,-racUser =>['',' '] ,'Error' =>['', ''] ,'rfaUplEmpty' =>['', ' '] ,'recUpdAclStp' =>['', ' '] ,'recUpdVerStp' =>['', ' '] ,'recDelAclStp' =>['', ' '] ,'recReadAclStp'=>['', ' '] ,'fldReqStp' =>['', ' '] ,'fldChkStp' =>['',' '] ,'home' =>['', ' '] ,'schpane' =>['', ' /'] ,'back' =>['<', ' '] ,'login' =>['', ' '] ,'frmCall' =>['', ' , , '] ,'frmCallOpn' =>[''] ,'frmCallNew' =>[' ', ' , '] ,'frmHelp' =>['', ' '] ,'frmErr' =>['', ' '] ,'frmName' =>['', ' '] ,'frmLso' =>['', " , , '--x'"] ,'frmLsoff' =>['------------x', ' '] ,'frmLsc' =>['',' , '] ,'frmName1' =>['', ' , '] ,'recNew' =>['', ' , '] ,'recRead' =>['', '() ; '] ,'recEdit' =>['', ' () '] ,'recPrint' =>['', ' '] ,'recXML' =>['XML', ' XML'] ,'recHist' =>['', ' '] ,'recIns' =>['', ' '] ,'recUpd' =>['', ' () '] ,'recDel' =>['', ' '] ,'recForm' =>['', ' , '] ,'recList' =>['', '() , ()'] ,'recQBF' =>['', ' () '] ,'recQBFReset' =>['', ' '] ,'-query' =>['', ' '] ,'-qkeyord' =>['SEEK', ' '] ,'-qjoin' =>['JOIN', ' FROM, WHERE'] ,'-qwhere' =>['WHERE', ' WHERE'] ,'-qurole' =>['UROLE', ' '] ,'-quname' =>['UNAME', ' '] ,'-qftext' =>['FULL TEXT', ' '] ,'-qversion' =>['VERSIONS', ' '] ,'-qorder' =>['ORDER BY', ' ORDER BY'] ,'-qlimit' =>['LIMIT', ' LIMIT'] ,'-qdisplay' =>['DISPLAY', ' '] ,'-qurl' =>['URL', ' URL , \'\''] ,'rfafolder' =>['', ' '] ,'rfauplfld' =>['', ' '] ,'rfaupdate' =>['+/-', ' , '] ,'rfaopen' =>['...', ' , '] ,'rfaclose' =>[''] ,'rfadelm' =>['', ' '] ,'ddlbopen' =>['...', ' '] ,'ddlbopenl' =>['>', ' '] ,'ddlbsubmit' =>['.', ' '] ,'ddlbreset' =>['c', ' '] ,'ddlbclose' =>['x', ' '] ,'ddlbfind' =>['..', ' '] ,'tvmVersions' =>[' ', ' '] ,'tvmHistory' =>[' ', ' , , '] ,'tvmReferences'=>[' ', ' '] ,'tvdIndex' =>[' ', ''] ,'tvdFTQuery' =>[' ', ' '] ,'-qftwhere' =>['FTQuery', ' '] ,'-qftord' =>['FTOrder', ' '] ,'-qftlimit' =>['FTLimit', ' '] ,'table' =>['', ' '] ,'id' =>['ID', ' ', 'id'] ,'ir' =>['', " "] ,'idrm' =>['', " , 'id' 'table'//'id'"] ,'idpr' =>['', " , 'id' 'table'//'id'"] ,'hierarchy' =>[''] ,'cuser' =>['', ' '] ,'creator' =>['', ' '] ,'ctime' =>['-', ' '] ,'uuser' =>['', ' '] ,'updater' =>['', ' '] ,'utime' =>['-', ' '] ,'idnv' =>['', ' , () '] ,'vtime' =>['', ' '] ,'status' =>['', ' , '] ,'todo' =>[''] ,'done' =>[''] ,'deleted' =>[''] ,'edit' =>['-'] ,'chk-out' =>['chk-out'] ,'all' =>[''] ,'auser' =>['-', ' , '] ,'actor' =>['-', ' , '] ,'arole' =>['-', ' , '] ,'actors' =>['-', ' , , '] ,'puser' =>['-', ' , '] ,'principal' =>['-', ' , '] ,'prole' =>['-', ' , '] ,'principals' =>['-', ' , , '] ,'manager' =>['', ' , '] ,'muser' =>['', ' , '] ,'mrole' =>['', ' , '] ,'managers' =>['', ' , , '] ,'owner' =>['', ' , '] ,'orole' =>['', ' , '] ,'owners' =>['', ' , , '] ,'user' =>['', ' '] ,'users' =>['-', ' , , '] ,'author' =>['', ' , '] ,'authors' =>['', ' , , '] ,'rrole' =>['', ' '] ,'readers' =>['', ' , , '] ,'mailto' =>['', ' , '] ,'record' =>['', ' '] ,'object' =>['', ' , '] ,'project' =>['', ', , , , '] ,'cost' =>['', ' '] ,'doctype' =>[' .', ' , '] ,'subject' =>['', ' '] ,'comment' =>['', " HTML . 'urlh://' (), 'urlr://' ( ), 'urlf://' ( ), 'key://' ( ${RISM1}), 'wikn://' ( ); [[xxx://...]], [[xxx://...][label]], [[xxx://...|label]]. "] ,'cargo' =>['', ' '] } ,'utf8ru' => { # See cptran(), utf8enc(), utf8dec(), $] >=5.008 # !!! Text::Iconv may be better # http://adult-hosting.ru/adult/hosting4/UTF-8.html # UTF-8 (8-bit Unicode Transformation Format) is a variable-length character encoding for Unicode created by Ken Thompson and Rob Pike. It is able to represent any universal character in the Unicode standard, yet is backwards compatible with ASCII. # UTF-8 uses one to four bytes (strictly, octets) per character, depending on the Unicode symbol. For example, only one byte is needed to encode the 128 US-ASCII characters in the Unicode range U+0000 to U+007F. # http://phpclub.ru/faq/wakka.php?wakka=encodings&v=35q # http://forum.net.ru/viewforum.php?f=4 "\xD0\x90"=>"\xC0","\xD0\x91"=>"\xC1","\xD0\x92"=>"\xC2","\xD0\x93"=>"\xC3","\xD0\x94"=>"\xC4" ,"\xD0\x95"=>"\xC5","\xD0\x81"=>"\xA8","\xD0\x96"=>"\xC6","\xD0\x97"=>"\xC7","\xD0\x98"=>"\xC8" ,"\xD0\x99"=>"\xC9","\xD0\x9A"=>"\xCA","\xD0\x9B"=>"\xCB","\xD0\x9C"=>"\xCC","\xD0\x9D"=>"\xCD" ,"\xD0\x9E"=>"\xCE","\xD0\x9F"=>"\xCF","\xD0\xA0"=>"\xD0","\xD0\xA1"=>"\xD1","\xD0\xA2"=>"\xD2" ,"\xD0\xA3"=>"\xD3","\xD0\xA4"=>"\xD4","\xD0\xA5"=>"\xD5","\xD0\xA6"=>"\xD6","\xD0\xA7"=>"\xD7" ,"\xD0\xA8"=>"\xD8","\xD0\xA9"=>"\xD9","\xD0\xAA"=>"\xDA","\xD0\xAB"=>"\xDB","\xD0\xAC"=>"\xDC" ,"\xD0\xAD"=>"\xDD","\xD0\xAE"=>"\xDE","\xD0\xAF"=>"\xDF","\xD0\x87"=>"\xAF","\xD0\x86"=>"\xB2" ,"\xD0\x84"=>"\xAA","\xD0\x8E"=>"\xA1","\xD0\xB0"=>"\xE0","\xD0\xB1"=>"\xE1","\xD0\xB2"=>"\xE2" ,"\xD0\xB3"=>"\xE3","\xD0\xB4"=>"\xE4","\xD0\xB5"=>"\xE5","\xD1\x91"=>"\xB8","\xD0\xB6"=>"\xE6" ,"\xD0\xB7"=>"\xE7","\xD0\xB8"=>"\xE8","\xD0\xB9"=>"\xE9","\xD0\xBA"=>"\xEA","\xD0\xBB"=>"\xEB" ,"\xD0\xBC"=>"\xEC","\xD0\xBD"=>"\xED","\xD0\xBE"=>"\xEE","\xD0\xBF"=>"\xEF","\xD1\x80"=>"\xF0" ,"\xD1\x81"=>"\xF1","\xD1\x82"=>"\xF2","\xD1\x83"=>"\xF3","\xD1\x84"=>"\xF4","\xD1\x85"=>"\xF5" ,"\xD1\x86"=>"\xF6","\xD1\x87"=>"\xF7","\xD1\x88"=>"\xF8","\xD1\x89"=>"\xF9","\xD1\x8A"=>"\xFA" ,"\xD1\x8B"=>"\xFB","\xD1\x8C"=>"\xFC","\xD1\x8D"=>"\xFD","\xD1\x8E"=>"\xFE","\xD1\x8F"=>"\xFF" ,"\xD1\x96"=>"\xB3","\xD1\x97"=>"\xBF","\xD1\x94"=>"\xBA","\xD1\x9E"=>"\xA2" } }; $IMG={ 'home' =>'portal.gif' ,'schpane' =>'folder.gif' ,'schframe' =>'folder.gif' ,'back' =>'back.gif' ,'login' =>'small/key.gif' ,'frmCall' =>'hand.up.gif' ,'frmHelp' =>'unknown.gif' ,'recNew' =>'generic.gif' ,'recRead' =>'up.gif' ,'recEdit' =>'quill.gif' ,'recPrint' =>'p.gif' ,'recXML' =>'script.gif' ,'recHist' =>'text.gif' ,'recIns' =>'burst.gif' ,'recUpd' =>'down.gif' ,'recDel' =>'broken.gif' ,'recForm' =>'forward.gif' ,'recList' =>'text.gif' ,'recQBF' =>'index.gif' ,'recQBFReset' =>'pie0.gif' ,'rfafolder' =>'folder.open.gif' }; 1; ####################### sub new { my $c=shift; my $s ={}; bless $s,$c; $s =$s->initialize(@_); } sub initialize { my $s =shift; my %opt =@_; $CACHE->{$s} ={}; $s->set(-env=>$opt{-env}) if $opt{-env}; %$s =( # -env =>undef # Environment variables setup -title =>'' # Application's title # ,-locale =>'' # Application's locale # ,-lang =>undef # Application's language # ,-charset =>undef # Application's charset # ,-lng =>'' # User's language # ,-lnglbl =>'' # -lbl key # ,-lngcmt =>'' # -cmt key ,-debug =>0 # Debug Mode ,-die =>$LNG->{-die} # die / croak / confess: &{$s->{-die} }('error') ,-warn =>$LNG->{-warn} # warn / carp / cluck : &{$s->{-warn}}('warning') ,-ermu =>'' # err markip user ,-ermd =>'' # err markup delimiter # ,-end0 =>undef # 'end' before trigger ,-endh =>{} # 'end' before hash # ,-end1 =>undef # 'end' after trigger # ,-var =>undef # Variables {}, see varLoad, varStore ,-log =>1 # Log file switch/handle, see logOpen ,-logm =>100 # Log list max size ,-c => { # Cache for computed values # ,-startinit =>undef # Started by initialize # ,-pth_tmp =>undef # Temporary files path, see pthForm('tmp') # ,-pth_var =>undef # Variable files path, see pthForm('var') # ,-pth_log =>undef # Log files path, see pthForm('log') # ,-logm =>[] # Log list # ,-user =>undef # User Name # ,-unames =>[] # User Names # ,-ugroups =>[] # User Groups } # ,-path =>'./dbix-web' # Path to file store, default below # ,-url =>'/dbix-web' # URL to file store, default below # ,-urf =>'file://./dbix-web'# Filesystem URL to file store, default below ,-host =>undef # Host Name, default below # ,-dbi =>undef # DBI object, if used # ,-dbiarg =>undef # DBI connection arguments string or array # ,-dbidsn =>undef # DBI connection string from -dbiarg # ,-dbiph =>undef # DBI placeholders ('?') dialect switch # ,-dbiACLike =>undef # DBI ACL LIKE options: rlike regexp,... # ,-dbiexpl =>undef # DBI explain switch: 0/1 # ,-cgi =>undef # CGI object ,-serial =>1 # Serialised: 1 - updates, 2 - updates & reads, 3 - reads ,-keyqn =>1 # query key ''/undef compatibility # ,-output =>undef # output sub{} instead of 'print' ,-table =>{} # database files # -field=>[name=>{}] # -mdefld=>{name=>{}} # -key =>[field] # -keycmp=>sub{} # key compare dbm sub{} # -ixcnd=>sub{}||1 # index condition # -ixrec=>sub{} # form index record # -optrec # optional records # -dbd =>'dbi'|'dbm' # database store # -recXXX # trigger or implementation # -subst # substitute another # -cgcXXX=>''|sub{} # cgi call implementation # -cgvXXX=>''|sub{} # cgi call presentation # -frmLso # form query option # -query # query condition hash # -qfilter # filters rows fetched # -qhref # query hyperlink hash or sub{} # -qhrcol # q h left columns # -qflghtml # !empty flag when '!h' # -qfetch # query fetch sub{} # -limit # query limit rows # -recRead # recRead condition hash # ,-user =>undef # User Name sub{} or value, default below ,-userln =>1 # User local short names switch # ,-usernt =>undef # User syntax alike WinNT # ,-udisp =>undef # User display group comments '-ug<>dc' or boolean # ,-unames =>[] # User Names sub{} or value # ,-ugroups =>[] # User Groups sub{} or value # ,-udflt =>sub{} # User Domains filter # ,-unflt =>sub{} # User Names filter # ,-ugflt =>sub{} # User Groups filter # ,-AuthUserFile # Apache Users file, optional # ,-AuthGroupFile # Apache Groups file, optional # ,-w32ldap =>[[win=>ldap]] # Windows ADSI LDAP users/groups store # ,-ldap =>''||[]||{} # LDAP constructor arguments, LDAP usage option # ,-ldapsrv =>''||[]||{} # LDAP constructor arguments # ,-ldapbind =>''||[]||{} # LDAP bind arguments (version => 3) # ,-ldapsearch =>{} # LDAP search defaults and basic filter # ,-ldapfu =>'' # LDAP users filter # ,-ldapfg =>'' # LDAP groups filter ,-ldapattr =>['uid','cn'] # LDAP internal and external names # ,-fswtr =>undef # File Store Writers, defaults in code # ,-fsrdr =>undef # File Store Readers ,-w32IISdpsn =>($ENV{SERVER_SOFTWARE}||'') =~/IIS/ ? 1 : 0 # MsIIS deimpersonation # ,&recXXX # DML command keywords # -table -form || record form class # -from -join[01] # -data # -key -where # -urole -uname # -ftext -version # -filter -limit # -order -keyord -group # -save -optrec -test -sel # DML record attributes # -new -file -fupd -editable # Record Manipulation Options: # ,-dbd =>undef # default database engine ,-autocommit =>1 # autocommit database mode # ,-limit =>undef||number # limit of selection # ,-affect =>undef||1 # rows number to affect by DML # ,-affected # rows number affected by DML # ,-fetched # rows number fetched by DBL # ,-limited # rows number limited by DBL # ,-index =>boolean # include materialized views support ,-idsplit =>1 # split complex rec ID to table and row ID: 0 || sub{} ,-wikn => # wikiname fields possible ['name','subject'] # Record Access Control rooles: ,-rac =>1 # switch on ,-racAdmWtr =>'Administrators,root' ,-racAdmRdr =>'Administrators,root' # ,-racReader =>[fieldnames] # readers fieldnames # ,-racWriter =>[fieldnames] # writers fieldnames # Record Version Control rooles: # ,-rvcInsBy =>'fieldname' # field for user name record inserted by # ,-rvcInsWhen =>'fieldname' # field for time record inserted when # ,-rvcUpdBy =>'fieldname' # field for user name record updated by # ,-rvcUpdWhen =>'fieldname' # field for time record updated when # ,-rvcVerWhen =>'fieldname' # field for time version created when # ,-rvcActPtr =>'fieldname' # field for actual record version pointer # ,-rvcChgState=>[fld=>states] # changeble states of record # ,-rvcCkoState=>[fld=>state ] # check-out state of record # ,-rvcDelState=>[fld=>state ] # deleted state of record # Record File Attachments rooles: ,-rfa =>1 # switch on # ,-rfdName =>sub{} # 'rfdName' formula for key processing # Record ID References # ,-ridRef =>[] # reference fields # Record Manipulation Triggers: # ,-recTrim0A =>sub{} # 'recTrim' trigger before UI action # ,-recForm =>'form'|sub{} # 'recForm' UI implementation # ,-recForm0A =>sub{} # 'recForm' trigger before UI action # ,-recForm0C =>sub{} # 'recForm' trigger before command # ,-recForm0R =>sub{} # 'recForm' trigger before row # ,-recFlim0R =>sub{} # 'recForm' limiter before row # ,-recForm1C =>sub{} # 'recForm' trigger after command # ,-recForm1A =>sub{} # 'recForm' trigger after UI action # ,-recEdt0A =>sub() # 'recEdt' trigger before UI action # ,-recEdt0R =>sub() # 'recEdt' trigger before row # ,-recChg0R =>sub() # 'recChg' trigger before row # ,-recChg0W =>sub() # 'recChg' trigger before write (and -recInsID) # ,-recEdt1A =>sub() # 'recEdt' trigger after UI action # ,-recNew =>'form'|sub{} # 'recNew' UI implementation # ,-recNew0C =>sub{} # 'recNew' trigger before command # ,-recNew0R =>sub{} # 'recNew' trigger before row # ,-recNew1C =>sub{} # 'recNew' trigger after command # ,-recIns =>'form'|sub{} # 'recIns' UI implementation # ,-recIns0C =>sub{} # 'recIns' trigger before row command # ,-recIns0R =>sub{} # 'recIns' trigger before row # ,-recInsID =>sub{} # 'recIns' trigger for key generation # ,-recIns1R =>sub{} # 'recIns' trigger after row # ,-recIns1C =>sub{} # 'recIns' trigger after row command # ,-recUpd =>'form'|sub{} # 'recUpd' UI implementation # ,-recUpd0C =>sub{} # 'recUpd' trigger before command # ,-recUpd0R =>sub{} # 'recUpd' trigger before each row # ,-recUpd1C =>sub{} # 'recUpd' trigger after command # ,-recDel =>'form'|sub{} # 'recDel' UI implementation # ,-recDel0C =>sub{} # 'recDel' trigger before command # ,-recDel0R =>sub{} # 'recDel' trigger before each row # ,-recDel1C =>sub{} # 'recDel' trigger after command # ,-recSel0C =>sub{} # 'recSel' trigger before command # ,-recRead =>'form'|sub{} # 'recRead' UI implementation # ,-recRead0C =>sub{} # 'recRead' trigger before row command # ,-recRead0R =>sub{} # 'recRead' trigger before row command # ,-recRead1R =>sub{} # 'recRead' trigger after row command # ,-recRead1C =>sub{} # 'recRead' trigger after row command # ,-recList =>'form'|sub{} # 'recList' UI implementation ,-tn =>{ # Template naming, see also 'ns' sub '' =>'' ,-guest =>'guest' # guest user name ,-guests =>'guests' # guest user group ,-users =>'users' # authenticated user default group ,-dbd =>'dbm' # defaultest data engine ,-id =>'id' # record identifier ,-key =>['id'] # record key ,-rvcInsBy =>'cuser' # user, record inserted by ,-rvcInsWhen =>'ctime' # time, record inserted when ,-rvcUpdBy =>'uuser' # user, record updated by ,-rvcUpdWhen =>'utime' # time, record updated when ,-rvcVerWhen =>'vtime' # time, version created when # 'auser' # actor user # 'arole' # actor roles # 'puser' # principal user # 'prole' # principal roles ,-rvcActPtr =>'idnv' # id of new version of record # 'idrm' # id of master record # 'idrr' # id of root reference # 'idpr' # id of previous record in cause chain # 'idpt' # point to record # 'idlr' # location record pointer ,-rvcState =>'status' # state of record ,-rvcAllState =>['ok','no','do','progress','delay','chk-out','edit','deleted'] ,-rvcFinState =>['status'=>'ok','no','deleted'] ,-rvcChgState =>['status'=>'edit','chk-out'] ,-rvcCkoState =>['status'=>'chk-out'] ,-rvcDelState =>['status'=>'deleted'] ,-ridSubject =>[qw(record object subject)] # subject fields | sub{} ,'tvmVersions' =>'versions' # versions view name ,'tvmHistory' =>'history' # history view name ,'tvmReferences'=>'references' # references view name ,'tvdIndex' =>'index' # index view name ,'tvdFTQuery' =>'fulltext' # full-text view name } # CGI server user interface # ,-httpheader =>{} # ,-htmlstart =>{} ,-icons =>'/icons' # Icons URL # ,-logo =>'' # Logotype to display # ,-search =>'' # '_search' frame URL ,-login =>'/cgi-bin/ntlm/'# Login URL # ,-menuchs =>[[]] # ,-menuchs1 =>[[]] # ,-form =>{} # user interface forms, see '-table' # ,-pcmd =>{} # command input parameters # ,-pdta =>{} # data input # ,-pout =>{} # parameters output (cursor) ); if (!$opt{-path} || ($opt{-path} =~/^(?:DocumentRoot|-DocumentRoot)$/i)) { my $pth =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0; $pth = $ENV{DOCUMENT_ROOT} ? $ENV{DOCUMENT_ROOT} .'/' : $pth =~/^(.+?[\\\/]wwwroot[\\\/])/i ? $1 : $pth =~/^(.+?[\\\/]inetpub[\\\/])/i ? $1 : $pth =~/^(.+?[\\\/])cgi-bin[\\\/]/i && -d ($1 .'htdocs') ? $1 .'htdocs/' : $pth =~/^(.+?[\\\/]apache[\\\/])/i && -d ($1 .'htdocs') ? $1 .'htdocs/' : $pth =~/^(.+[\\\/])[^\\\/]*$/ ? $1 : -d '../htdocs' ? '../htdocs/' : -d '../wwwroot' ? '../wwwroot/' : './'; $opt{-path} =$pth .'dbix-web'; } elsif ($opt{-path} =~/^(?:ServerRoot|-ServerRoot|-path)$/i) { my $pth =$^O eq 'MSWin32' ? scalar(Win32::GetFullPathName($0)) : $0; $pth = ($^O eq 'MSWin32') && ($pth =~/^(.+?[\\\/]inetpub[\\\/])/i) ? $1 : $ENV{DOCUMENT_ROOT} && ($ENV{DOCUMENT_ROOT} =~/^(.+[\\\/])[^\\\/]*$/) ? $1 : $pth =~/^(.+?[\\\/])cgi-bin[\\\/]/i && -d ($1 .'htdocs') ? $1 .'/' : $pth =~/^(.+?[\\\/]apache[\\\/])/i && -d ($1 .'htdocs') ? $1 .'/' : $pth =~/^(.+[\\\/])[^\\\/]*$/ ? $1 : -d '../htdocs' ? '../' : -d '../wwwroot' ? '../' : './'; $opt{-path} =$pth .'dbix-web'; } $RISM2 ='.rfd'; # for set(-cgibus) $s->set(%opt); $s->{-url} =cgibus($s) ? '/cgi-bus' : '/dbix-web' if !$s->{-url}; $s->set(-locale=>POSIX::setlocale(&POSIX::LC_CTYPE())) if !$s->{-locale}; $s->set(-die=>($ENV{GATEWAY_INTERFACE}||'') =~/CGI/ ? 'CGI::Carp qw(fatalsToBrowser warningsToBrowser)' : 'Carp') if !$opt{-die}; $s->set(-host=> ($ENV{COMPUTERNAME}||$ENV{HOSTNAME}||eval('use Sys::Hostname;hostname')||'localhost') =~/^([\d.]+|[\w\d_]+)/ ? $1 : 'unknown' ) if !$s->{-host}; $s->set(-user=>sub{$ENV{REMOTE_USER}||$ENV{USERNAME}||$s->{-tn}->{-guest}}) if !$s->{-user}; $s->set(-recTrim0A=>sub{ # $self, {command}, {data} foreach my $k (keys %{$_[2]}) { next if !defined($_[2]->{$k}); if ($_[2]->{$k} =~/^\s+/) {$_[2]->{$k} =$'} if ($_[2]->{$k} =~/\s+$/) {$_[2]->{$k} =$`} } $_[2]}) if !$s->{-recTrim0A}; $s->set(-recInsID=>sub{ # !!! database lookup may be better and faster, # but appropriate insulation level may be needed $_[0]->varLock(); $_[2]->{'id'} =lc($_[0]->{-host}) .strpad($_[0],$_[0]->{-var}->{-table}->{$_[1]->{-table}}->{-recInsID} =dwnext($_[0],$_[0]->{-var}->{-table}->{$_[1]->{-table}}->{-recInsID})); $_[0]->varStore(); $_[2]->{'id'}}) if !$s->{-recInsID}; if ($ENV{MOD_PERL}) { Apache->push_handlers("PerlCleanupHandler" ,sub{eval{$s->end}; eval('Apache::DECLINED;')}); } $ENV{TMP} =$ENV{TEMP} =$ENV{TMP}||$ENV{tmp}||$ENV{TEMP}||$ENV{temp} ||$ENV{TMPDIR} # see CGI.pm source ||$s->pthForm('tmp'); $s->{-c}->{-startinit} =1; $s } sub class { substr($_[0], 0, index($_[0],'=')) } sub set { return(keys(%{$_[0]})) if scalar(@_) ==1; return($_[0]->{$_[1]}) if scalar(@_) ==2; my ($s, %opt) =@_; foreach my $k (keys(%opt)) { $s->{$k} =$opt{$k}; } if ($opt{-env}) { my $env =$s->{-env} =ref($opt{-env}) eq 'CODE' ? &{$opt{-env}}(@_) : $opt{-env}; if (ref($env) eq 'HASH') { foreach my $k (keys %$env) { if (defined($env->{$k})){$ENV{$k} =$env->{$k}} else {delete($ENV{$k})} } } } if ($opt{-die}) { my ($s, $he, $hw) =($_[0]); if (ref($opt{-die})) {} elsif ($opt{-die} =~/^(perl|core)$/i) { $s->{-warn} =$LNG->{-warn}; $s->{-die} =$LNG->{-die}; } elsif ($opt{-die}) { my $m =($s->{-die} =~/^([^\s]+)\s*/ ? $1 : $s->{-die}) .'::'; ($he, $hw) =($SIG{__DIE__}, $SIG{__WARN__}); $s->{-warn} =eval('use ' .$s->{-die} .';\\&' .$m .($s->{-debug} ?'cluck' :'carp' )); $s->{-die} =eval('use ' .$s->{-die} .';\\&' .$m .($s->{-debug} ?'confess' :'croak')); $he =($he ||'') ne ($SIG{__DIE__}||'') ? $SIG{__DIE__} : undef; $hw =($hw ||'') ne ($SIG{__WARN__}||'') ? $SIG{__WARN__} : undef; } $SIG{__DIE__} =sub{ return if ineval(); my $s =$SELF; # || (*DB::args{ARRAY} && $DB::args[0]); $s =undef if !isa($s, 'DBIx::Web'); $s && eval{$s->logRec('Die', ($_[0] =~/(.+)[\n\r]+$/ ? $1 : $_[0]))}; $s && eval{$s->recRollback()}; ref($he) && &$he}; $SIG{__WARN__} =sub{ return if ineval(); my $s =$SELF; # || (*DB::args{ARRAY} && $DB::args[0]); $s =undef if !isa($s, 'DBIx::Web'); $s && eval{$s->logRec('Warn',($_[0] =~/(.+)[\n\r]+$/ ? $1 : $_[0]))}; ref($hw) && &$hw}; } if (exists $opt{-locale}) { $s->{-lng} =''; $s->{-lnglbl} =''; $s->{-lngcmt} =''; $s->{-lang} =lc($opt{-locale} =~/^(\w\w)/ ? $1 : 'en'); $s->{-charset} =$opt{-locale} =~/\.(.+)$/ ? $1 : '1252'; } if (exists $opt{-lng}) { $s->{-lng} =lc($s->{-lng}); $s->{-lnglbl} =$s->{-lng} ? '-lbl' .'_' .$s->{-lng} : ''; $s->{-lngcmt} =$s->{-lng} ? '-cmt' .'_' .$s->{-lng} : ''; } if (exists $opt{-autocommit}) { $s->{-dbi}->{AutoCommit} =$opt{-autocommit} if $s->{-dbi}; } if ($opt{-cgibus} && !ref($opt{-cgibus})) { $s->{-recInsID} =sub{ # recIns() row ID generation trigger # cgi-bus 'gwo.cgi' $_[2]->{'id'} =($_[0]->user =~/^([^@]+)@(.+)$/ ? $2 .'\\' .$1 : $_[0]->user) .'/' .$_[0]->strtime('yyyymmddhhmmss')}; $s->{-rfdName} =sub{ # convert record's key into directory name # cgi-bus 'gwo.cgi', '-ksplit, tmsql::fsname() # 'rfdName()'/'-rfdName' local $_ =$_[1]; my $r =''; return($r) if !$_; while ($_ =~/([\\\/])/) { $_ =$'; my $v =$` .$1; $v =~s/([^a-zA-Z0-9])/uc sprintf("_%02x",ord($1))/eg; $r .=$v .'/' }; $r .= join('/' ,map { if (defined($_) && $_ ne '') { my $v =$_; $v =~s/([^a-zA-Z0-9])/uc sprintf("_%02x",ord($1))/eg; $v } else {return()} } substr($_,0,4),substr($_,4,2),substr($_,6,2),substr($_,8,2),substr($_,10)); $r }; $RISM2 ='$'; # record identification end special mark # tmsql 'sub fsname' # rmlIdSplit() / -idsplit, cgiForm(), ui... } if ($opt{-urf} && (ref($opt{-urf}) eq 'CODE')) { $s->{-urf} =$opt{-urf}= &{$opt{-urf}}($s); } if ($opt{-urf} && (substr($opt{-urf},0,1) eq '-')) { $s->{-urf} = $opt{-urf} ne '-path' ? $s->{$opt{-urf}} : $s->{-cgibus} && cgibus($s) ?('file://' .cgibus($s)) :('file://' .$s->{$opt{-urf}}) } $s } sub cgibus { # (self, set) -> is cgi-bus mode? return($_[0]->{-cgibus}) if !ref($_[0]->{-cgibus}); local $_; $_ =&{$_[0]->{-cgibus}}($_[0] , $_ =$_[0]->{-pcmd} && ($_[0]->{-pcmd}->{-table} || $_[0]->{-pcmd}->{-form}) || $_[0]->cgi->param('_table') || $_[0]->cgi->param('_form') || $_[0]->cgi->param('_key') || 'default' , $_[1]); $_[0]->set(-cgibus=>$_) if $_[1]; $_ } sub lng { my $l =$LNG->{$_[0]->{-lng}} || $LNG->{''}; my $m; @_ <3 ? ($m =$l->{$_[1]} ||$LNG->{''}->{$_[1]}) && ($m->[0] ||$m->[1]) ||$_[1] : @_ <4 ? ( (($m =$l->{$_[2]} ||$l->{'-' .$_[2]}) && $m->[$_[1]]) || (($m =$LNG->{''}->{$_[2]} ||$LNG->{''}->{'-' .$_[2]}) && $m->[$_[1]]) || $_[2]) : eval {my $r =lng(@_[0..2]); my $v =!ref($_[3]) ? $_[3] : ref($_[3]) eq 'CODE' ? &{$_[3]}(@_) : strdata($_[0], $_[3]); $v ='undef' if !defined($v); $r =~s/\$_/$v/ge ? $r : "$r $v" } } sub lang { my $l =$LNG->{$_[0]->{-lang}} || $LNG->{''}; my $m; @_ <3 ? ($m =$l->{$_[1]} ||$LNG->{''}->{$_[1]}) && ($m->[0] ||$m->[1]) ||$_[1] : @_ <4 ? ( (($m =$l->{$_[2]} ||$l->{'-' .$_[2]}) && $m->[$_[1]]) || (($m =$LNG->{''}->{$_[2]} ||$LNG->{''}->{'-' .$_[2]}) && $m->[$_[1]]) || $_[2]) : eval {my $r =lng(@_[0..2]); my $v =!ref($_[3]) ? $_[3] : ref($_[3]) eq 'CODE' ? &{$_[3]}(@_) : strdata($_[0], $_[3]); $v ='undef' if !defined($v); $r =~s/\$_/$v/ge ? $r : "$r $v" } } sub lnghash { # locale hash (self, index, array) return $_[2] ? { map {($_, lng($_[0],$_[1],$_)) } ref($_[2]) eq 'ARRAY' ? @{$_[2]} : ()} : ($LNG->{$_[0]->{-lng}} || $LNG->{''}) } sub lngslot { # localised slot (self, object, keyname) $_[1]->{$_[2] .'_' .$_[0]->{-lng}} || $_[1]->{$_[2]} } sub lnglbl { # localised label (self, object,...) foreach my $e (@_[1..$#_]) { next if !ref($e); my $v =$e->{$_[0]->{-lnglbl}} || $e->{-lbl}; next if !$v; return(ref($v) ? &$v(@_) : $v) } !ref($_[$#_]) && $_[1]->{$_[$#_]} ? lng($_[0],0,$_[1]->{$_[$#_]}) : '' } sub lngcmt { # localised comment (self, object,...) foreach my $e (@_[1..$#_]) { next if !ref($e); my $v =$e->{$_[0]->{-lngcmt}} || $e->{-cmt} || $e->{$_[0]->{-lnglbl}} || $e->{-lbl}; next if !$v; return(ref($v) ? &$v(@_) : $v) } !ref($_[$#_]) && $_[1]->{$_[$#_]} ? lng($_[0],1,$_[1]->{$_[$#_]}) : '' } sub charset { # character set name, as for web return($LNG->{''}->{-charset}->[0]) if !$_[0]->{-charset}; $_[0]->{-charset} =~/^\d/ ? 'windows-' .$_[0]->{-charset} : $_[0]->{-charset} } sub charpage { # character page name, as for Encode charset($_[0]) =~/^windows-(\d+)/ ? "cp$1" : charset($_[0]); } sub ineval { # is inside eval{}? # for PerlEx and mod_perl # see CGI::Carp::ineval comments and errors return $^S if !($ENV{GATEWAY_INTERFACE} && ($ENV{GATEWAY_INTERFACE} =~/PerlEx/)) && !$ENV{MOD_PERL}; my ($i, @a) =(1); while (@a =caller($i)) { # $_[0] && $_[0]->logRec('ineval',$i,$a[0],$a[1],$a[2],$a[3]); return(0) if $a[0] =~/^(?:PerlEx::|Apache::Perl|Apache::Registry|Apache::ROOT)/i; return(1) if $a[3] eq '(eval)'; $i +=1; } } sub die { &{$_[0]->{-die}}($_[0]->{-ermu} .(($#_ <2) && ($_[1] !~/[\r\n]$/) ? ($_[1] .$_[0]->{-ermd}) : join('',@_[1..$#_]))) } sub warn { &{$_[0]->{-warn}}(@_[1..$#_]) } sub start { # start session my $s =shift; my %o =@_; if (!$s->{-c}->{-startinit}) { $CACHE->{$s} ={}; $s->{-c} ={}; } delete $s->{-c}->{-startinit}; $s->{-fetched} =0; $s->{-limited} =0; $s->{-affected}=0; $s->{-var}->{'_handle'}->destroy if $s->{-var} && $s->{-var}->{'_handle'}; $s->w32IISdpsn() if (($ENV{SERVER_SOFTWARE}||'') =~/IIS/) && ((defined($s->{-w32IISdpsn}) ? $s->{-w32IISdpsn} ||0 : 2) >1) && !$s->cgi->param('_qftwhere'); unless ((($ENV{SERVER_SOFTWARE}||'') =~/IIS/) && $s->cgi->param('_qftwhere')) { $s->varLoad(!$s->{-serial} ? 0 : $s->{-serial} >2 ? LOCK_EX : $s->{-serial} >1 ? LOCK_SH : $s->{-serial} >0 ? LOCK_SH : 0); $s->logOpen if $s->{-log} && !ref($s->{-log}); $s->{-log}->lock(0) if ref($s->{-log}); } $s->set(@_); $s } sub end { # end session my $s =shift; &{$s->{-end0}}($s) if $s->{-end0}; if ($s->{-dbi}) { # $s->recCommit(); $s->logRec('end'); eval{$s->{-dbi}->disconect}; delete $s->{-dbi}; } eval{$s->{-cgi}->DESTROY()} if $s->{-cgi}; # delete $INC{'CGI.pm'}; delete $s->{-cgi}; $CGI::Q =undef; foreach my $k (sort keys %{$s->{-endh}}) {eval{&{$s->{-endh}->{$k}}($s)}}; $s->{-endh} ={}; $s->smtp(undef) if $s->{-smtp}; if ($s->{-var} && $s->{-var}->{'_handle'}) { $s->{-var}->{'_handle'}->destroy; delete $s->{-var}->{'_handle'}; } if (ref($s->{-log})) { $s->{-log}->destroy; $s->{-log} =undef; } eval{$s->{-c}->{-ldap}->unbind} if $s->{-c}->{-ldap}; $s->{-c} ={}; $CACHE->{$s} ={}; &{$s->{-end1}}($s) if $s->{-end1}; $s } sub DESTROY { my $s =shift; eval{$s->{-cgi}->DESTROY()} if $s->{-cgi}; delete $s->{-cgi}; $CGI::Q =undef; $s->smtp(undef) if $s->{-smtp}; if ($s->{-var} && $s->{-var}->{'_handle'}) { eval{$s->{-var}->{'_handle'}->destroy}; delete $s->{-var}->{'_handle'}; } if (ref($s->{-log})) { eval{$s->{-log}->destroy}; $s->{-log} =undef; } eval{$s->{-c}->{-ldap}->unbind} if $s->{-c}->{-ldap}; $s->{-c} ={}; $CACHE->{$s} ={}; $s } sub setup { # Setup script execution my ($s) =@_; print "Writing sample '.htaccess-$VERSION' file...\n"; my $pth =$s->pthForm('tmp') && $s->{-path}; $pth =~s/\\/\//g; $s->hfNew('+>', ($pth .'/.htaccess-' .$VERSION))->lock(LOCK_EX) ->store( "# Default data and pulic directory tree configuration.\n" ."# Should be included in 'httpd.conf'.\n" ."# Include " .($pth .'/.htaccess-' .$VERSION) ."\n" ."\n" ."#\n" ."#\tLoadModule ntlm_module modules/mod_ntlm.so\n" ."#\n" ."#\n" ."#\tLoadModule sspi_auth_module modules/mod_auth_sspi.so\n" ."#\n" ."\n" ."#\tAllowOverride All\n" ."\tAllowOverride Limit AuthConfig\n" ."\tOptions -FollowSymLinks\n" ."\tAccessFileName .htaccess\n" ."\tOrder Allow,Deny\n" ."\tAllow from All\n" ."#\t\n" ."#\t\tAuthType NTLM\n" ."#\t\tNTLMAuth On\n" ."#\t\tNTLMAuthoritative On\n" ."#\t\tNTLMOfferBasic On\n" ."#\t\n" ."#\t\n" ."#\t\tAuthType SSPI\n" ."#\t\tSSPIAuth On\n" ."#\t\tSSPIAuthoritative On\n" ."#\t\tSSPIOfferBasic On\n" ."#\t\n" .($s->{-AuthUserFile} ?("\tAuthUserFile " .$s->{-AuthUserFile} ."\n") :("#\tAuthUserFile " .($pth ."/var/ualist") ."\n")) ."\tAuthGroupFile " .($s->{-AuthGroupFile} ||($pth ."/var/uagroup")) ."\n" ."\n" ."#Alias /dbix-web/rfa/ \"$pth/\"\n" ) ->destroy; $s->pthForm('rfa'); print "Executing , some SQL DML error messages may be ignored...\n\n"; local $s->{-dbiargpv} =$s->{-dbiarg}; local $s->{-affect} =undef; local $s->{-rac} =undef; my $row; my $cmd =''; my $cmt =''; while ($row =) { $row = if 0; chomp($row); if ($cmd && ($row =~/^#/)) { my $v; chomp($cmd); print $cmt ||$cmd, " -> "; local $SELF =$s; local $_ =$s; if ($cmd =~/^\s*\{/) { $v =eval($cmd); print $@ ? $@ : 'ok' } else { $v =$s->dbi->do($cmd); print $s->dbi->err ? $s->dbi->errstr : 'ok' } print ': ', defined($v) ? $v : 'undef', "\n\n"; $cmd =''; $cmt =''; } if ($row =~/^\s*#*\s*$/ || $row =~/^\s+#/ || $row eq '') { next } elsif ($row =~/^#/) { $cmt =$row } else { $cmd .=($cmd ? "\n" : '') .$row } } $s } ######################################################### # Misc Data methods ######################################################### sub dwnext { # next digit-word string value # self, string, ? min length my $v =$_[1] ||'0'; for(my $i =1; $i <=length($v); $i++) { next if ord(substr($v,-$i,1)) >=ord('z'); substr($v,-$i,1)=chr(ord(substr($v,-$i,1) eq '9' ? chr(ord('a')-1) : substr($v,-$i,1)) +1); substr($v,-$i+1)='0' x ($i-1) if $i >1; return($_[2] && length($v) <$_[2] ? '0' x ($_[2] -length($v)) .$v : $v) } $v =chr(ord('0')+1) .('0' x length($v)); $_[2] && length($v) <$_[2] ? '0' x ($_[2] -length($v)) .$v : $v } sub grep1 { # first non-empty value # self, list # self, sub{}, list local $_; if (ref($_[1]) ne 'CODE') { foreach (@_[1..$#_]) {return($_) if $_} } else { my $t; foreach (@_[2..$#_]) {$t =&{$_[1]}(); return $t if $t} } return(()) } sub shiftkeys { # shift keys from array my ($s,$a,$e) =@_; # (self, array, string regexp | sub{} condition) local $_; my @r; while (scalar(@$a)) { if ( ref($e) ? &$e($s, $_ =$a->[0], 0) : $a->[0] =~/^(?:$e)$/) { push @r, shift @$a, shift @$a; } else { last } } @r } sub splicekeys { # splice keys from array my ($s,$a,$e) =@_; # (self, array, string regexp | sub{} condition) local $_; my $i =0; my @r; while (scalar(@$a) && ($i <=$#$a)) { if ( ref($e) ? &$e($_[0], $_ =$a->[$i], $i) : $a->[$i] =~/^(?:$e)$/) { push @r, $a->[$i], $a->[$i+1]; splice @$a,$i,2; } else { $i++ } } @r } sub max { # maximal number (($_[1]||0) >($_[2]||0) ? $_[1] : $_[2])||0 } sub min { # minimal number (($_[1]||0) >($_[2]||0) ? $_[2] : $_[1])||0 } sub orarg { # argument of true result shift(@_); my $s =ref($_[0]) ? shift :index($_[0], '-') ==0 ? eval('sub{' .shift(@_) .' $_}') :eval('sub{' .shift(@_) .'($_)}'); local $_; foreach (@_) {return $_ if &$s($_)}; undef } sub strpad { # string padding # self, string, ?pad char, ?min length length($_[1]) <$NLEN ? ($_[2]||'0') x ($_[3] ||$NLEN -length($_[1])) .$_[1] : $_[1]; } sub strdata { # Stringify any data structure my $v =$_[1]; # self, data !defined($v) ? '' : !ref($v) ? $v # ($v =~s/([\x00-\x1f\\])/sprintf("\\x%02x",ord($1))/eg ? $v : $v) : isa($v, 'ARRAY') ? join(', ', map {my $v =$_; ref($v) ? do {my $x =strdata($_[0],$v); $x =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg; '(' .$x .')' } : !defined($v) ? '' : $v =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg ? $v : $v } @$v) : isa($v, 'HASH') ? join(', ', map {my ($k, $v) =($_, $_[1]->{$_}); $k =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg; ref($v) ? do {my $x =strdata($_[0],$v); $x =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg; $k .'=(' .$x .')' } : !defined($v) ? "$k=" : $v =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg ? "$k=$v" : "$k=$v" } sort keys %$v) : $v } sub strdatah { # Stringify hash data structure return(strdata(@_)) if $#_ <2; my $r =''; for (my $i =1; $i <$#_; $i +=2) { my ($k, $v) =@_[$i, $i+1]; $k =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg; $r .=$k .'=' .(!defined($v) ? '' : ref($v) ? do {my $x =strdata($_[0],$v); $x =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg; '(' .$x .')' } : $v =~s/([\x00-\x1f,;=\\\)\(])/sprintf("\\x%02x",ord($1))/eg ? $v : $v) .',' } chop($r); $r } sub strquot { # Quote and Escape string my $v =$_[1]; return('undef') if !defined($v); $v =~s/([\\'])/\\$1/g; $v =~s/([\x00-\x1f])/sprintf("\\x%02x",ord($1))/eg; $v =~/^\d+$/ ? $v : ('\'' .$v .'\''); } sub strHTML { # Stringify HTML, convert to pure text my $h =defined($_[1]) ? $_[1] : ''; my $t =''; $h =$' if $h =~/^[\s\r\n]+/; $h =~s/>[\r\n]+\s*<\/(?:th|td)/i) || ($h =~/^\/(?:li)\s*>\s*<(?:li|\/ul)/i)) { $t .="\n" if $t !~/^\s*$/; $h =$'; } elsif ( ($h =~/^\/(?:h\d|div|p|td|th|tr|code|kbd|ul)/i) || ($h =~/^(?:br|hr|li|table)/i)) { $t .="\n" if $t !~/^\s*$/ } $h =$' if $h =~/>/; } $t .=$h; $t =$_[0]->htmlUnescape($t); $t =~s/\n{2,}/\n\n/g; $t } sub strDiff { # Strings difference # (-opt, old, new) -> changes # 'h'tml conversion if ishtml(); # 'w'ords, 'r'ows, 's'entences input break; # 'b'rief, 'p'lane output my ($s,$o,$s1,$s2) =@_; my $r =''; $o ='-br' if !$o; $s1 ='' if !defined($s1); $s2 ='' if !defined($s2); $s1 =$s->strHTML($s1) if ($o =~/h/) && $s->ishtml($s1); $s2 =$s->strHTML($s2) if ($o =~/h/) && $s->ishtml($s2); return($s2) if ($s1 eq '') || ($s2 eq ''); my $br =sub{ my ($h, $t)=($_[0], ''); while ($h =~/([^\n]{100})/) { $t .=$`; $h =$'; my $v =$1; if ($v =~/[ \t]$/) { $t .=$` ."\n" } elsif ($h =~/^[ \t]/) { $t .=$v ."\n" } elsif ($v !~/[ \t]/) { $t .=$v } elsif ($v =~/\s+([^\s]+)$/) { $t .=$` ."\n"; $h =$1 .$h } } $t .=$h; $t }; if (0) {} elsif (($o =~/w/) # words diff && eval('use Algorithm::Diff; 1')) { my $cat =sub{ my($b,$v)=@_[1..2]; # (buf, sign, acc, last) $_[2] =''; if (($b =~/^=/) && ($o =~/b/)) { $v =$' if $v =~/^[\s\n]+/; $v =$` if $v =~/[\s\n]+$/; $v =~/\n+/; if ($_[0] eq '') { $v =$1 if $v =~/\n+([^\n]+)$/ } elsif ($_[3]) { $v =$1 if $v =~/^([^\n]+)\n+/ } elsif ($v =~/\n+/) { my $t =$`; if ($' =~/\n+([^\n]+)$/) { $v =$t ."\n...\n" .$1 } } $v =' ' .$v; } $v =&$br($v) if $o =~/p/; $v =~s/\n/\n$b /g; $_[0] .=$b .$v ."\n"; }; $s1 =~s/([^ \t])\n/$1 \n/g; $s1 =~s/\n([^ \t])/\n $1/g; $s2 =~s/([^ \t])\n/$1 \n/g; $s2 =~s/\n([^ \t])/\n $1/g; my ($p, $ax, $ay, $au) =('','','',''); foreach my $d (Algorithm::Diff::sdiff([split /[ \t]+/, $s1],[split /[ \t]+/, $s2])) { if ($p ne $d->[0]) { &$cat($r,'-:',$ax) if length($ax) >0; &$cat($r,'+:',$ay) if length($ay) >0; &$cat($r,'=:',$au) if length($au) >0; } $p =$d->[0]; $ax .=' ' .$d->[1] if $p eq '-'; $ax .=' ' .$d->[1] if $p eq 'c'; $ay .=' ' .$d->[2] if $p eq '+'; $ay .=' ' .$d->[2] if $p eq 'c'; $au .=' ' .$d->[1] if $p eq 'u'; } &$cat($r,'-:',$ax,1) if length($ax) >0; &$cat($r,'+:',$ay,1) if length($ay) >0; &$cat($r,'=:',$au,1) if length($au) >0; } elsif (eval('use Algorithm::Diff; 1')) { # strings diff if ($o =~/r/) { # row break $s1 =&$br($s1); $s2 =&$br($s2); } elsif ($o =~/s/) { # sentence break $s1 =~s/\.[ \t]+/\.\n/; $s2 =~s/\.[ \t]+/\.\n/; } my $cat =sub{ my($b,$v)=@_[1..2]; # (buf, sign, acc, last) $_[2] =''; if (($b =~/^=/) && ($o =~/b/)) { $v =$' if $v =~/^[\s\n]+/; $v =$` if $v =~/[\s\n]+$/; $v =~/\n+/; if ($_[0] eq '') { $v =$1 if $v =~/\n+([^\n]+)$/ } elsif ($_[3]) { $v =$1 if $v =~/^([^\n]+)\n+/ } elsif ($v =~/\n+/) { my $t =$`; if ($' =~/\n+([^\n]+)$/) { $v =$t ."\n...\n" .$1 } } } else { chomp($v) } $v =&$br($v) if $o =~/p/; $v =~s/\n/\n$b /g; $_[0] .=$b .' ' .$v ."\n"; }; my ($p, $ax, $ay, $au) =('','','',''); foreach my $d (Algorithm::Diff::sdiff([split /\n+/, $s1],[split /\n+/, $s2])) { if ($p ne $d->[0]) { &$cat($r,'-:',$ax) if length($ax) >0; &$cat($r,'+:',$ay) if length($ay) >0; &$cat($r,'=:',$au) if length($au) >0; } $p =$d->[0]; $ax .=$d->[1] ."\n" if $p eq '-'; $ax .=$d->[1] ."\n" if $p eq 'c'; $ay .=$d->[2] ."\n" if $p eq '+'; $ay .=$d->[2] ."\n" if $p eq 'c'; $au .=$d->[1] ."\n" if $p eq 'u'; } &$cat($r,'-:',$ax,1) if length($ax) >0; &$cat($r,'+:',$ay,1) if length($ay) >0; &$cat($r,'=:',$au,1) if length($au) >0; } else { # simplest diff $r = ($s1 eq '') || ($s2 eq '') ? $s2 : (length($s1) >255) && (length($s2) >255) ? '...Algorithm::Diff should be used...' : $s2; } $r } sub htfrDiff { # html reformat for difference $_[1] =~/\n*[-+=]:/ ? "" .join("\n" , map { $_ =~/^([-+=]):\s*/ ? "" : "" } split /\s*\n/, $_[1]) ."
$1:$'
$_
" : $_[1] } sub datastr { # Data structure from String # (for data structure strings only!) # self, string, ?unescape my $v =$_[1]; $v =~s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg if $_[2]; $v =~/^[^\(\)]+[=]/ ? {map { my ($n, $v) =(/^\s*([^=]+)\s*=\s*(.*)$/ ? ($1,$2) : ()); !defined($n) ||($n eq '') ? () : !defined($v) ? ($n =>$v) : $v =~/^\(/ ? ($n =>datastr($_[0], substr($v,1,-1), 1) ||undef) : $v =~s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg ? ($n =>$v) : ($n =>$v) } split /\s*[,;]\s*/, $v} : $v =~/[,;]/ ? [grep {defined($_)} map { !defined($_) ? () : /^\(/ ? datastr($_[0], substr($_,1,-1), 1) ||undef : s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg ? $_ : $_ } split / *[,;] */, $v] : $v =~s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg ? $v : $v } sub dsdClone { # Clone data structure !ref($_[1]) ? $_[1] : ref($_[1]) eq 'ARRAY' ? [map {ref($_) ? dsdClone($_[0], $_) : $_} @{$_[1]}] : ref($_[1]) eq 'HASH' ? {map {($_, dsdClone($_[0], $_[1]->{$_}))} keys %{$_[1]}} : $_[1] } sub dsdMk { # Data structure dump to string my ($s, $d) =@_; eval('use Data::Dumper'); my $o =Data::Dumper->new([$d]); $o->Indent(1); $o->Dump(); } sub dsdQuot { # Quote and Escape data structure $#_ <2 # (self, ?'=>', data struct) ? dsdQuot($_[0],'=> ',$_[1]) : !ref($_[2]) # (, hash delim, value) -> stringified ? strquot($_[0],$_[2]) : ref($_[2]) eq 'ARRAY' ? '[' .join(', ', map {dsdQuot(@_[0..1],$_) } @{$_[2]}) .']' : ref($_[2]) eq 'HASH' ? '{' .join(', ', map {$_ .$_[1] .dsdQuot(@_[0..1],$_[2]->{$_}) } sort keys %{$_[2]}) .'}' : strquot($_[0],$_[2]) } sub dsdParse { # Data structure dump string to perl structure my ($s, $d) =@_; eval('use Safe'); Safe->new()->reval($d) } sub strtime { # Stringify Time my $s =shift; my $msk =@_ ==0 || $_[0] =~/^\d+$/i ? 'yyyy-mm-dd hh:mm:ss' : shift; my @tme =@_ ==0 ? localtime(time) : @_ ==1 ? localtime($_[0]) : @_; $msk =~s/yyyy/%Y/; $msk =~s/yy/%y/; $msk =~s/mm/%m/; $msk =~s/mm/%M/i; $msk =~s/dd/%d/; $msk =~s/hh/%H/; $msk =~s/hh/%h/i; $msk =~s/ss/%S/; #eval('use POSIX'); POSIX::strftime($msk, @tme) } sub timestr { # Time from String my $s =shift; my $msk =@_ <2 || !$_[1] ? 'yyyy-mm-dd hh:mm:ss' : shift; my $ts =shift; my %th; while ($msk =~/(yyyy|yy|mm|dd|hh|MM|ss)/) { my $m=$1; $msk =$'; last if !($ts =~/(\d+)/); my $d =$1; $ts =$'; $d -=1900 if $m eq 'yyyy' ||$m eq '%Y'; $m =chop($m); $m ='M' if $m eq 'm' && $th{$m}; $m =lc($m) if $m ne 'M'; $th{$m}=$d; } #eval('use POSIX'); POSIX::mktime($th{'s'}||0,$th{'M'}||0,$th{'h'}||0,$th{'d'}||0,($th{'m'}||1)-1,$th{'y'}||0,0,0,(localtime(time))[8]) } sub timeadd { # Adjust time to years, months, days,... my $s =$_[0]; my @t =localtime($_[1]); my $i =5; foreach my $a (@_[2..$#_]) {$t[$i] += ($a||0); $i--} #eval('use POSIX'); POSIX::mktime(@t[0..5],0,0,$t[8]) } sub cptran { # Translate strings between codepages my ($s,$f,$t,@s) =@_; if (($] >=5.008) && eval("use Encode; 1")) { map {$_= /oem|866/i ? 'cp866' : /ansi|1251/i ? 'cp1251' : /koi/i ? 'koi8-r' : /8859-5/i ? 'iso-8859-5' : $_ } $f, $t; map {Encode::is_utf8($_) ? ($_ =Encode::encode($t, $_)) : Encode::from_to($_, $f, $t) if defined($_) } @s; } else { foreach my $v ($f, $t) { # See also utf8enc, utf8dec if ($v =~/oem|866/i) {$v ='񦧨'} elsif ($v =~/ansi|1251/i) {$v ='Ũ'} elsif ($v =~/koi/i) {$v ='ţ'} elsif ($v =~/8859-5/i) {$v =''} } map {eval("~tr/$f/$t/") if defined($_)} @s; } @s >1 ? @s : $s[0]; } sub ishtml { # Looks like HTML? ($_[1] ||'') =~m/^<(?:(?:B|BIG|BLOCKQUOTE|CENTER|CITE|CODE|DFN|DIV|EM|I|KBD|P|SAMP|SMALL|SPAN|STRIKE|STRONG|STYLE|SUB|SUP|TT|U|VAR)\s*>|(?:BR|HR)\s*\/{0,1}>|(?:A|BASE|BASEFONT|DIR|DIV|DL|!DOCTYPE|FONT|H\d|HEAD|HTML|IMG|IFRAME|MAP|MENU|OL|P|PRE|TABLE|UL)\b)/i } sub htmlEscape { join '', map { my $v =$_; return('') if !defined($_); $v =~s{&}{&}gso; $v =~s{<}{<}gso; $v =~s{>}{>}gso; $v =~s{"}{"}gso; $v } @_[1..$#_] } sub htmlEscBlnk { join '', map { my $v =$_; return(' ') if !defined($_) || $_ eq ''; $v =~s{&}{&}gso; $v =~s{<}{<}gso; $v =~s{>}{>}gso; $v =~s{"}{"}gso; $v } @_[1..$#_] } sub htmlUnescape { join '', map { my $v =$_; return('') if !defined($_); $v =~s[&(.*?);]{ local $_ = $1; /^amp$/i ? "&" : /^quot$/i ? '"' : /^gt$/i ? ">" : /^lt$/i ? "<" : $_; }gex; $v } @_[1..$#_] } sub urlEscape { join '', map { my $v =$_; return('') if !defined($_); $v =~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg; $v } @_[1..$#_] } sub urlUnescape { join '', map { local $_ =$_; return('') if !defined($_); tr/+/ /; s/%([0-9a-fA-F]{2})/chr hex($1)/ge; $_ } @_[1..$#_] } sub urlCat { my $r =$_[1] =~/\?/ ? ($_[1] .$HS) : ($_[1] .'?'); for (my $i =2; $i <$#_; $i+=2) {$r .=urlEscape($_[0], $_[$i]) .'=' .urlEscape($_[0], $_[$i+1]) .$HS} chop($r); $r } sub urlCmd { my $r =($_[1]||'') .'?'; for (my $i =2; $i <$#_; $i+=2) { $r .=urlEscape($_[0], $_[$i] =~/^-/ ? '_' .$' : $_[$i]) .'=' .urlEscape($_[0], ref($_[$i+1]) ? strdata($_[0], $_[$i+1]) : $_[$i+1]) .$HS } chop($r); $r } sub xmlEscape { join '', map { my $v =$_; return('') if !defined($v); $v =~s/([\\"<>])/sprintf('\\x%02x',ord($1))/ge; # $v =~s/([\\"<])/\\$1/g; # $v =~s/([^\w\d ,<.>\/?:;"'\[\]{}`~!@#$%^&*()-_=+\\|])/ ord($1) < 0x20 ? sprintf('\\x%02x',ord($1)) : $1/ge; $v =~s/([\x00-\x1F])/sprintf('\\x%02x',ord($1))/ge; $v } @_[1..$#_] } sub xmlAttrEscape { xmlEscape(@_) } sub xmlTagEscape { join '', map { my $v =$_; return('') if !defined($v); $v =~s/([\\"<>])/sprintf('\\x%02x',ord($1))/ge; # $v =~s/([\\"<])/\\$1/g; # $v =~s/([^\w\d\s\n ,<.>\/?:;"'\[\]{}`~!@#$%^&*()-_=+\\|])/ ord($1) < 0x20 ? sprintf('\\x%02x',ord($1)) : $1/eg; $v =~s/([\x00-\x08\x0B-\x0C\x0E-\x1F]|[&])/sprintf('\\x%02x',ord($1))/eg; # \t=0x09; \n=0x0A; \r=0x0D; $v } @_[1..$#_] } sub xmlUnescape { join '', map { my $v =$_; return('') if !defined($v); $v =~s/\\\\/\\/g; $v =~s|(\\+)([<"])| int(length($1)/2)*2 == length($1) ? ('\\' x (length($1)-1) .$2) : ($1 .$2)|ge; $v =~s|(\\+)(x\d+)| int(length($1)/2)*2 == length($1) ? ('\\' x (length($1)-1) .chr(hex($2))) : ($1 .$2)|ge; $v } @_[1..$#_] } sub lsTag { # Attribute list to tag strings list my($c, $v, $n);# htmlEscape, urlEscape, tagEscape, self, tagname, attr=>value,... $#_+1 !=2*int(($#_+1)/2) ? 0 : substr($_[$#_],0,1) eq "\n" ? ($n =$_[$#_]) : ($c =$_[$#_]); ((!ref($_[$[+4]) ? ('<', $_[$[+4] ,(map {$_[$_] ? (defined($_[$_+1]) ? (' ', substr($_[$_],0,1) eq '-' ? substr($_[$_],1) : $_[$_], '="' , &{$_[$_] ne 'href' ? $_[$[] : $_[$[+1]} ($_[$[+3], !ref($_[$_+1]) ? $_[$_+1] : strdata($_[$[+3], $_[$_+1])) , '"') : ()) : eval{$c =$_[$_]; $v =$_[$_+1]; ()} } map {$_*2+3} $[+1..int(($#_-3)/2) ) ,(!defined($c) ? ' />' : $c eq '0' ? '>' : ('>' , (ref($v) eq 'CODE') && ($v =&{$v}) && 0 ? () : ref($v) eq 'ARRAY' ? &lsTag(@_[$[..$[+3], $v) : defined($v) ? &{$_[$[+2]}($_[$[+3], $v) : () , '') ) ) : ref($_[$[+4]) eq 'ARRAY' ? (map {ref($_) ne 'ARRAY' ? &{$_[$[+2]}($_[$[+3], $_) : lsTag(@_[$[..$[+3], @$_)} @{$_[$[+4]}) : ref($_[$[+4]) eq 'HASH' && eval{$v =$_[$[+4]; $c =$v->{'-'}||$v->{'-tag'}||'tag'} ? ('<', $c ,(map {defined($v->{$_}) ?(' ' , substr($_,0,1) eq '-' ? substr($_, 1) : $_, '="' , &{$_ ne 'href' ? $_[$[] : $_[$[+1]} ($_[$[+3], !ref($v->{$_}) ? $v->{$_} : strdata($_[$[+3], $v->{$_})) ,'"') :() } sort grep {$_ && $_ !~/^-(tag|data|)$/} keys %$v) , (grep {exists($v->{$_}) && eval{$v =$v->{$_}}} '', '-data') ? ('>' ,(ref($v) eq 'CODE') && ($v =&{$v}) && 0 ? () : ref($v) eq 'ARRAY' ? &lsTag(@_[$[..$[+3], $v) : defined($v) ? &{$_[$[+2]}($_[$[+3], $v) : () ,'') : exists($v->{0}) ? '>' : ' />' ) : () ), !$n ? () : $n) } sub htlsTag { # Attribute list to html strings list lsTag(\&htmlEscape, \&urlEscape, \&htmlEscape, @_) } sub xmlsTag { # Attribute list to xml strings list lsTag(\&xmlAttrEscape, \&xmlAttrEscape, \&xmlTagEscape, @_) } sub utf8enc { # Encode to UTF8, see also cptran() my $r =$_[1]; if ($] >=5.008) { my $cp =eval('!${^ENCODING}') && $_[0]->charpage(); eval("use encoding '$cp', STDIN=>undef, STDOUT=>undef") if $cp; eval("use Encode"); $r =Encode::encode_utf8($r); eval('no encoding') if !$cp; return($r); } my $t =$LNG->{'utf8' .($_[0]->{-lang}||'')}; return($r) if !$t; foreach my $k (keys %$t) { my $v =$t->{$k}; $r =~ s/$v/$k/ig } $r; } sub utf8dec { # Decode from UTF8, see also cptran() my $r =$_[1]; if ($] >=5.008) { my $cp =eval('!${^ENCODING}') && $_[0]->charpage(); eval("use encoding '$cp', STDIN=>undef, STDOUT=>undef") if $cp; eval("use Encode"); $r =Encode::decode_utf8($r); eval('no encoding') if $cp; $r =Encode::encode($cp,$r) if $cp; return($r); } my $t =$LNG->{'utf8' .($_[0]->{-lang}||'')}; return($r) if !$t; foreach my $k (keys %$t) { my $v =$t->{$k}; $r =~ s/$k/$v/ig } $r; } ######################################################### # Misc Utility methods ######################################################### sub cgi { # CGI object return($_[0]->{-cgi}) if $_[0]->{-cgi}; if (!eval("use CGI (); 1") ||!eval("use CGI (); 1")) { my $e =$@ ||'undef'; $_[0]->logRec('error',"use CGI -> $e"); # eval('use CGI::Carp'); CGI::Carp::croak("use CGI -> $e\n"); &{$_[0]->{-die}}("use CGI -> $e\n"); } no warnings; # consider also $CGI::Q - default CGI object $_[0]->{-cgi} =$CGI::Q =eval('local $^W =0; CGI->new()'); if (!$_[0]->{-cgi}) { my $e =$@ ||'undef'; $_[0]->logRec('error',"CGI::new() -> $e"); # eval('use CGI::Carp'); CGI::Carp::croak("CGI::new() -> $e\n"); &{$_[0]->{-die}}("CGI::new() -> $e\n"); } if ($_[0]->{-cgi}->{'.cgi_error'}) { $_[0]->{-c}->{'.cgi_error'} =$_[0]->{-cgi}->{'.cgi_error'}; $_[0]->logRec('error','CGI::new() -> ' .$_[0]->{-cgi}->{'.cgi_error'}) } $CGI::XHTML =0; $CGI::USE_PARAM_SEMICOLONS =$HS eq ';' ? 1 : 0; if ((($ENV{SERVER_SOFTWARE}||'') =~/IIS/i) || ($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER})) { $CGI::NPH =1 } if ($ENV{PERLXS}) { } if (($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/) { } $_[0]->{-cgi} } sub url { # CGI script URL if ($#_ >0) { local $^W =0; my $v =($_[0]->{-cgi}||$_[0]->cgi)->url(@_[1..$#_]); if ($v) {} elsif (!($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/))) {} elsif (($#_ >2) ||(($#_ ==2) && !$_[2])) {} elsif ($_[1] eq '-relative') { $v =$ENV{SCRIPT_NAME}; $v =$1 if $v =~/[\\\/]([^\\\/]+)$/; } elsif ($_[1] eq '-absolute') { $v =$ENV{SCRIPT_NAME} } return($v) } return($_[0]->{-c}->{-url}) if $_[0]->{-c}->{-url}; local $^W =0; $_[0]->{-c}->{-url} =$_[0]->cgi->url(); if ($ENV{PERLXS} ||(($ENV{GATEWAY_INTERFACE}||'') =~/PerlEx/)) { $_[0]->{-c}->{-url} .= (($_[0]->{-c}->{-url} =~/\/$/) ||($ENV{SCRIPT_NAME} =~/^\//) ? '' : '/') .$ENV{SCRIPT_NAME} if ($_[0]->{-c}->{-url} !~/\w\/\w/) && $ENV{SCRIPT_NAME}; } $_[0]->{-c}->{-url} } sub dbi { # DBI connection object return ($_[0]->{-dbi}) if $_[0]->{-dbi}; $_[0]->{-dbidsn} =ref($_[0]->{-dbiarg}) ? $_[0]->{-dbiarg}->[0] : $_[0]->{-dbiarg}; $_[0]->{-dbi} =$_[0]->dbiConnect() || &{$_[0]->{-die}}($_[0]->lng(0,'dbi') .": DBI::conect() -> failure\n"); $_[0]->{-dbi}->{AutoCommit} =$_[0]->{-autocommit}; if (!$_[0]->{-dbistart}) { } elsif (ref($_[0]->{-dbistart}) eq 'CODE') { &{$_[0]->{-dbistart}}(@_) } elsif (ref($_[0]->{-dbistart}) eq 'ARRAY') { foreach my $v (@{$_[0]->{-dbistart}}) { $_[0]->logRec('dbi',$v); eval{$_[0]->{-dbi}->do($v)}; next if !$_[0]->{-dbi}->err; $_[0]->logRec($_[0]->lng(0,'Error'), $_[0]->{-dbi}->errstr); } } else { $_[0]->logRec('dbi',$_[0]->{-dbistart}); eval{$_[0]->{-dbi}->do($_[0]->{-dbistart})}; if ($_[0]->{-dbi}->err) { $_[0]->logRec($_[0]->lng(0,'Error'), $_[0]->{-dbi}->errstr); } } $_[0]->{-dbi} } sub dbiEng { # DBI engine name if ($_[1]) { # (? name ) -> match | () -> dsn my $v =$_[1]; ($_[0]->{-dbidsn} || $_[0]->{Driver}->{Name}) =~/\bDBI:\Q$v\E\b/i } else { $_[0]->{-dbidsn} || $_[0]->{Driver}->{Name} } } sub dbiConnect {# DBI connecting with optional DBI:Proxy:hostname=127.0.0.1 eval('use PerlEx::DBI') if $ENV{GATEWAY_INTERFACE} =~/PerlEx/; eval('use Apache::DBI') if $ENV{MOD_PERL}; return(undef) if !eval("use DBI; 1;"); my $c=ref($_[0]->{-dbiarg}) ? $_[0]->{-dbiarg}->[0] : $_[0]->{-dbiarg}; if ($c =~/^DBI:Proxy:hostname=127\.0\.0\.1;/i) { # "dbi:Proxy:hostname=127.0.0.1;port=3334;proxy_no_finish=1;dsn=DBI:mysql:" # dbi->{Driver}->{Name} eq 'Proxy' my $i =2; my $r; while (!$r && $i) { $r =DBI->connect(ref($_[0]->{-dbiarg}) ? @{$_[0]->{-dbiarg}} : $_[0]->{-dbiarg}); return($r) if $r; if (--$i) { my $h =$c=~/hostname=([^;]+)/ ? $1 : ''; my $p =$c=~/port=([^;]+)/ ? $1 : ''; my $x =$^X; # \\?\D:\Share\B\Perl\bin\PerlIS.dll $x =$' if $x =~/^\\\\\?\\/; $x =$` .'perl.exe' if $x =~/(?:PerlIS|PerlEx)\d*\.dll$/i; my $a ="$x -e\"use DBI::ProxyServer; DBI::ProxyServer::main('--localaddr'=>'$h','--localport'=>'$p')\""; # '--mode'=>'single','--logfile'=>'STDERR','--debug'=>1 # $_[0]->die($a); if ($^O eq 'MSWin32') { $_[0]->logRec("Win32::Process($x, $a)"); eval('use Win32::Process'); $Win32::Process::Create::ProcessObj =$Win32::Process::Create::ProcessObj; Win32::Process::Create($Win32::Process::Create::ProcessObj ,$x ,$a ,0 ,&CREATE_NEW_CONSOLE ,'.') || &{$_[0]->{-die}}("Win32::Process($x, $a) -> $! $^E\n"); } elsif (1) { $_[0]->logRec("system($a)"); system(1,$a) && &{$_[0]->{-die}}("system($a) -> $!\n"); } } } return($r) } (0 && $_[0]->{-autocommit} && (eval{DBI->connect_cached(ref($_[0]->{-dbiarg}) ? @{$_[0]->{-dbiarg}} : $_[0]->{-dbiarg})})) || (eval{DBI->connect(ref($_[0]->{-dbiarg}) ? @{$_[0]->{-dbiarg}} : $_[0]->{-dbiarg})}) } sub dbiQuote { # DBI quote string $_[0]->dbi->quote(@_[1..$#_]) } sub dbiLikesc { # DBI escape 'like' join('', map {my $v =$_; $v =~s/([\\%_])/\\$1/g; $v} @_[1..$#_]) } sub hfNew { # New file handle object local $SELF =$_[0]; DBIx::Web::FileHandle->new(-parent=>$_[0] ,@_ >2 ? (-mode=>$_[1], -name=>$_[2]) :@_ >1 ? (-name=>$_[1]) : ()) } sub ccbNew { # New condition code block object local $SELF =$_[0]; DBIx::Web::ccbHandle->new($_[1]) } sub dbmNew { # New isam datafile object local $SELF =$_[0]; DBIx::Web::dbmHandle->new(-parent=>$_[0], @_ >2 ? @_[1..$#_] : (-name=>$_[1])) } sub dbmTable { # Get isam datafile object return(&{$_[0]->{-die}}('Bad table \'' .$_[1] .'\'' .$_[0]->{-ermd})) if !$_[1]; $CACHE->{$_[0]}->{'-dbm/' .$_[1]} ||($CACHE->{$_[0]}->{'-dbm/' .$_[1]} =$_[0]->dbmNew( -name =>$_[0]->pthForm('dbm' ,( $_[0]->{-table}->{$_[1]} && $_[0]->{-table}->{$_[1]}->{-expr} || $_[1])) ,-table =>$_[0]->{-table}->{$_[1]} ,-lock =>LOCK_SH))->opent } sub dbmTableClose { # Close isam datafile object if opened return(&{$_[0]->{-die}}('Bad table \'' .$_[1] .'\'' .$_[0]->{-ermd})) if !$_[1]; if ($_[1] eq '*') { # $_[0]->logRec('dbmTableClose',$_[1]); foreach my $k (keys %{$CACHE->{$_[0]}}) { next if $k !~/^-dbm\//; dbmTableClose($_[0], $') } return($_[0]) } return($_[0]) if !$CACHE->{$_[0]}->{'-dbm/' .$_[1]}; # $_[0]->logRec('dbmTableClose',$_[1]); $CACHE->{$_[0]}->{'-dbm/' .$_[1]}->close(); delete $CACHE->{$_[0]}->{'-dbm/' .$_[1]}; $_[0] } sub dbmTableFlush { # Reopen isam datafile object if opened return(&{$_[0]->{-die}}('Bad table \'' .$_[1] .'\'' .$_[0]->{-ermd})) if !$_[1]; if ($_[1] eq '*') { # $_[0]->logRec('dbmTableFlush',$_[1]); foreach my $k (keys %{$CACHE->{$_[0]}}) { next if $k !~/^-dbm\//; dbmTableFlush($_[0], $') } return($_[0]) } return($_[0]) if !$CACHE->{$_[0]}->{'-dbm/' .$_[1]}; # $_[0]->logRec('dbmTableFlush',$_[1]); $CACHE->{$_[0]}->{'-dbm/' .$_[1]}->close(); $CACHE->{$_[0]}->{'-dbm/' .$_[1]}->opent(); } sub osCmd { # OS Command # -'i'gnore retcode my $s =shift; my $opt =substr($_[0],0,1) eq '-' ? shift : ''; my $sub =ref($_[$#_]) eq 'CODE' ? pop : undef; my $r; my $o; local(*RDRFH, *WTRFH); $s->logRec('osCmd', @_); if ($^O eq 'MSWin32' # !!! arguments may need to be quoted || $^X =~/(?:perlis|perlex)\d*\.dll$/i) { # ISAPI, DB_File operation problem hacks if (!$sub) { if (($opt !~/h/) && ($^X =~/(?:perlis|perlex)\d*\.dll$/i ? $_[0] !~/^(?:xcopy)/ # !!! problematic programs : 1) ) { my $c =join(' ', @_) .' 2>&1'; @$o =`$c`; } elsif (system(@_) ==-1) { @$o =($!,$^E); $r =-1; } } else { # !!! command's output will be lost open(WTRFH, '|-', join(' ', @_) .' >nul 2>&1') && defined(*WTRFH) || return(&{$_[0]->{-die}}(join(' ',$s->lng(0,'osCmd'),@_) .' -> ' .$! .$_[0]->{-ermd})||0); my $ls =select(); select(WTRFH); $| =1; &$sub($s) if $sub; select($ls); eval{close(WTRFH)}; } } else { eval('use IPC::Open2'); my $pid = IPC::Open2::open2(\*RDRFH, \*WTRFH, @_); if ($pid) { if ($sub) { my $select =select(); select(WTRFH); $| =1; &$sub($s); select($select); } @$o =; waitpid($pid,0); } else { @$o =($!,$^E); $r =-1; } } $r =$?>>8 if !$r; return(&{$s->{-die}}(join(' ',$s->lng(0,'osCmd'),@_) .($opt !~/h/ ? '' : ' -> ' .join('',@{$o||[]})) ." -> $r" .$s->{-ermd})||0) if $r && $opt !~/i/; if ($o) {foreach my $e (@$o) { chomp($e); $s->logRec('osCmd',$e) }} !$r ? $o ||[] : undef } sub nfopens { # opened files (`net file`) # (mask, ?container) return(undef) if $^O ne 'MSWin32'; my $rc =$_[2]||[]; my $mask =$_[1]||''; $mask =~s/\//\\/ig; #[map {chomp($_); $_} map {/^\d+\s+(.+)\s+\d+[\n\r\s]*$/ ? $1 : $_} grep /^\d+\s*\Q$mask\E/i, `net file`] my $o =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); Win32::OLE->GetObject("WinNT://' .(eval{Win32::NodeName()}||$ENV{COMPUTERNAME}) .'/lanmanserver")'); return(undef) if !$o; if (ref($rc) eq 'HASH') { %$rc =map {(substr($_->{Path}, length($mask)+1), $_->{User} .': ' .substr($_->{Path}, length($mask)+1)) } grep {(eval{$_->{Path}}||'') =~/^\Q$mask\E/i } Win32::OLE::in($o->Resources()); # %$rc =(1=>'1.1',2=>'2.1',3=>'3.1'); $rc =undef if !%$rc } else { @$rc =map {eval{substr($_->{Path}, length($mask)+1)} } grep {(eval{$_->{Path}}||'') =~/^\Q$mask\E/i # $_->GetInfo; } Win32::OLE::in($o->Resources()); $rc =undef if !@$rc } $rc } sub nfclose { # close opened files (`net file /close`) # (mask, [filelist]) return(0) if $^O ne 'MSWin32'; my $mask =$_[1]||''; $mask =~s/\//\\/ig; my $list =$_[2]||[]; my $o =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); Win32::OLE->GetObject("WinNT://' .(eval{Win32::NodeName()}||$ENV{COMPUTERNAME}) .'/lanmanserver")'); return(0) if !$o; foreach my $f (grep {$_ && (eval{$_->{Path}}||'')=~/^\Q$mask\E/i } Win32::OLE::in($o->Resources())) { my $n =eval{$f->{Path} =~/^\Q$mask\E[\\\/]*(.+)/i ? $1 : undef}; next if !$n || !grep /^\Q$n\E$/i, @$list; $_[0]->osCmd('net','file',$f->{Name},'/close'); } 1 } sub output { # Output to user, like print, but redefinable (!$_[0]->{-output} ? print @_[1..$#_] : &{$_[0]->{-output}}(@_)) && $_[0] } sub outhtm { # Output HTML tag output($_[0], htlsTag(@_)) } sub outhtml { # Output HTML tag output($_[0], htlsTag(@_)) } sub outxml { # Output XML tag output($_[0], xmlsTag(@_)) } sub smtp { # SMTP object # (| undef | sub{}) if (!$_[0]->{-smtp}) {} elsif ((scalar(@_) >1) && !$_[1]) { $_[0]->{-smtp}->quit() if $_[0]->{-smtp}; delete $_[0]->{-smtp}; } elsif ($_[0]->{-smtp}) { if (ref($_[1])) { local $^W=undef; return(&{$_[1]}($_[0],$_[0]->{-smtp})); } return($_[0]->{-smtp}) if $_[0]->{-smtp}; } $_[0]->{-smtp} =eval { local $^W=undef; eval("use Net::SMTP"); $_[0]->{-smtphost} ? Net::SMTP->new($_[0]->{-smtphost}) : CORE::die('name required') }; return(&{$_[0]->{-die}}("SMTP host '" .$_[0]->{-smtphost} ."': $@\n")) if !$_[0]->{-smtp} ||$@; return(&{$_[1]}($_[0],$_[0]->{-smtp})) if ref($_[1]); $_[0]->{-smtp}; } sub smtpAdr { # SMTP address translate ($_[1] =~/^([^\\]+)\\(.+)$/ ? $2 : $_[1]) .((index($_[1],'@') <0) && $_[0]->{-smtpdomain} ? '@' .$_[0]->{-smtpdomain} : '') } sub smtpAdrd { # SMTP address displayable translate return($_[1]) if $_[1] =~/udisp($_[1]) ||$_[1]; unless ($d =~s/<([^<>]+)>/'<' .$_[0]->smtpAdr($_[1]) .'>'/e) { $d .=' <' .$_[0]->smtpAdr($_[1]) .'>' } $d } sub smtpSend { # SMTP mail msg send my ($s, %a) =@_; return($s) if !$s->{-smtphost}; local $s->{-smtpdomain} =$s->{-smtpdomain} || ($s->{-smtphost} && $s->smtp(sub{$_[1]->domain()})) || 'nothing.net'; local $s->{-pcmd} =$s->{-pcmd} ||{}; local $s->{-pcmd}->{-frame} =undef; $a{-from} =$a{-from} ||$a{-sender} ||$s->user; $a{-from} =&{$a{-from}}($s,\%a) if ref($a{-from}) eq 'CODE'; $a{-from} =$s->smtpAdrd($a{-from}); $a{-to} =&{$a{-to}}($s,\%a) if ref($a{-to}) eq 'CODE'; $a{-to} =[grep {$_} split /\s*[,;]\s*/, ($a{-to} =~/^\s*(.*)\s*$/ ? $1 : $a{-to})] if $a{-to} && !ref($a{-to}) && ($a{-to} =~/[,;]/); $a{-to} =ref($a{-to}) ? [map {$s->smtpAdrd($_)} @{$a{-to}}] : $s->smtpAdrd($a{-to}) if $a{-to}; $a{-sender} =$s->smtpAdr($a{-sender} ||$a{-from} ||$s->user); $a{-recipient} =$a{-recipient} ||$a{-to}; $a{-recipient} =&{$a{-recipient}}($s,\%a) if ref($a{-recipient}) eq 'CODE'; $a{-recipient} =[grep {$_} split /\s*[,;]\s*/, ($a{-recipient} =~/^\s*(.*)\s*$/ ? $1 : $a{-recipient})] if $a{-recipient} && ref($a{-recipient}) && ($a{-recipient} =~/[,;]/); return($s) if !$a{-recipient}; $a{-recipient} =ref($a{-recipient}) ? [map {$s->smtpAdr($_)} @{$a{-recipient}}] : $s->smtpAdr($a{-recipient}); if (!defined($a{-data})) { my $koi =(($a{-charset}||$s->charset()) =~/1251/); $a{-subject} = ref($a{-subject}) eq 'CODE' ? &{$a{-subject}}($s,\%a) : ref($a{-subject}) ? join(' ', map { !defined($a{-pout}->{$_}) ? () : ($a{-pout}->{$_}) } @{$a{-subject}}) : $a{-pout} ? $s->mdeSubj($a{-pout}) : '' if ref($a{-subject}) ||!defined($a{-subject}); $a{-data} =''; $a{-data} .='From: ' .($koi ? $s->cptran('ansi','koi',$a{-from}) : $a{-from}) ."\cM\cJ"; $a{-data} .='Subject: ' .($koi ? $s->cptran('ansi','koi',$a{-subject}) : $a{-subject}) ."\cM\cJ"; $a{-data} .='To: ' .($koi ? $s->cptran('ansi','koi', ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to}) : (ref($a{-to}) ? join(', ',@{$a{-to}}) : $a{-to})) ."\cM\cJ" if $a{-to}; $a{-data} .="MIME-Version: 1.0\cM\cJ"; $a{-data} .='Content-type: ' .($a{-pout} ||$a{-html} ? 'text/html' : 'text/plain') .'; charset=' .($a{-charset}||$s->charset()) ."\cM\cJ"; $a{-data} .='Content-Transfer-Encoding: ' .($a{-encoding} ||'8bit') ."\cM\cJ"; $a{-data} .="\cM\cJ"; if ($a{-pout}) { $a{-form} =$a{-form} || $a{-pcmd} && ($a{-pcmd}->{-form} ||$a{-pcmd}->{-table}); $a{-data} .=do{ local $s->{-c}->{-httpheader} =1; # local $s->{-htmlstart} ={ref($s->{-htmlstart}) ? %{$s->{-htmlstart}} : (), -xbase=>$s->url}; $s->htmlStart($a{-form})}; $a{-data} .='' ."\n"; local $s->{-output} =sub{$a{-data} .=join('',@_[1..$#_])}; # local $a{-pout} ={%{$a{-pout}}}; # read-only supposed local $a{-pcmd} ={($a{-pcmd} ? %{$a{-pcmd}} : ()) , -edit=>undef, -print=>1, -mail=>1 , -cmd=>'recRead', -cmg=>'recRead'}; local $s->{-pout} =$a{-pout}; local $s->{-pcmd} =$a{-pcmd}; $s->cgiForm($a{-form} , $a{-pcmd}->{-cmdf} ||$a{-pcmd}->{-cmdt} , $a{-pcmd} , $a{-pout} ); $a{-data} .=$s->htmlEnd(); } $a{-data} .=$a{-html} ||$a{-text} ||''; # $s->logRec('smtpSend',%a); # $s->logRec('smtpSend',$a{-data}); } return($s) if !$s->{-smtphost}; $s->logRec('smtpSend',$a{-recipient}); local $^W=undef; $s->smtp->mail($a{-sender} =~/<\s*([^<>]+)\s*>/ ? $1 : $a{-sender}) ||return(&{$_[0]->{-die}}("SMTP sender \'" .$a{-sender} ."'" .$_[0]->{-ermd})); $s->smtp->to(ref($a{-recipient}) ? (map { $_ && /<\s*([^<>]+)\s*>/ ? $1 : $_ } @{$a{-recipient}}) : $a{-recipient}) ||return(&{$_[0]->{-die}}("SMTP recipient \'" .(ref($a{-recipient}) ? join(', ',$a{-recipient}) : $a{-recipient}) ."'" .$_[0]->{-ermd})); $s->smtp->data($a{-data}) ||return(&{$_[0]->{-die}}("SMTP data \'" .$a{-data} ."'" .$_[0]->{-ermd})); $s->smtp->dataend() ||return(&{$_[0]->{-die}}("SMTP dataend" .$_[0]->{-ermd})); $s; } ######################################################### # Filesystem methods ######################################################### sub pthForm { # Form filesystem path for 'tmp'|'log'|'var'|'dbm'|'rfa' join('/', $_[0]->{-c}->{'-pth_' .$_[1]} ||pthForm_(@_), @_[2..$#_]); } sub pthForm_{ my $p =($_[0]->{-c}->{'-pth_' .$_[1]} =($_[1] eq 'tmp' && ($ENV{TMP} ||$ENV{tmp} ||$ENV{TEMP} ||$ENV{temp})) ||($_[0]->{-cgibus} && ($_[1] eq 'rfa') && $_[0]->{-cgibus}) ||join('/', $_[0]->{-path}, $_[1])); if (!-d $p) { $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; $_[0]->pthMk($p); $_[0]->hfNew('+>', "$p/.htaccess")->lock(LOCK_EX) ->store("\nOrder Deny,Allow\nDeny from All\n\n") ->destroy if $_[1] ne 'rfa'; if ($ENV{OS} && $ENV{OS}=~/Windows_NT/i) { $p =~s/\//\\/g; $_[0]->osCmd('cacls' ,"\"$p\"" ,'/T','/C' ,'/E' # for 'rfa' or late $_[0]->{-w32IISdpsn} ,'/G' ,(map{(m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_) .':F' } ref($_[0]->{-fswtr}) ? (@{$_[0]->{-fswtr}}) : ($_[0]->{-fswtr}||eval{Win32::LoginName})) ,sub{CORE::print "Y\n"}) } } $_[0]->{-c}->{'-pth_' .$_[1]} } sub pthMk { # Create directory if needed return(1) if -d $_[1]; my $a =''; foreach my $e (split /\//, $_[1]) { $a .=$e; if (!-d $a) { $_[0]->logRec('mkdir', $a) if !$_[0]->{-log} ||ref($_[0]->{-log}); mkdir($a, 0777) ||return(&{$_[0]->{-die}}($_[0]->lng(0,'pthMk') .": mkdir('$a') -> $!" .$_[0]->{-ermd})||0); } $a .='/' } 2; } sub pthGlob { # Glob directory my $s =shift; my @ret; if ($^O ne 'MSWin32') { CORE::glob(@_) } elsif (-e $_[0]) { push @ret, $_[0]; @ret } else { my $msk =($_[0] =~/([^\/\\]+)$/i ? $1 : ''); my $pth =substr($_[0],0,-length($msk)); $msk =~s/\*\.\*/*/g; $msk =~s:(\(\)[].+^\-\${}[|]):\\$1:g; $msk =~s/\*/.*/g; $msk =~s/\?/.?/g; local (*DIR, $_); opendir(DIR, $pth eq '' ? './' : $pth) || return(&{$s->{-die}}($s->lng(0,'pthGlob') .": opendir('$pth') -> $! ($^E)" .$s->{-ermd})||0); while(defined($_ =readdir(DIR))) { next if $_ eq '.' || $_ eq '..' || $_ !~/^$msk$/i; push @ret, "${pth}$_"; } closedir(DIR) || return(&{$s->{-die}}($s->lng(0,'pthGlob') .": closedir('$pth') -> $!" .$s->{-ermd})||0); @ret } } sub pthGlobn { # Glob filenames only map {$_ =~/[\\\/]([^\\\/]+)$/ ? $1 : $_} shift->pthGlob(@_) } sub pthGlobns { # Glob filenames sorted use locale; map {$_ =~/[\\\/]([^\\\/]+)$/ ? $1 : $_ } sort { (-d $a) && (!-d $b) ? -1 : (!-d $a) && (-d $b) ? 1 : lc($a) cmp lc($b) } $_[0]->pthGlob(@_[1..$#_]) } sub pthRm { # Remove filesystem path # '-r' - recurse subdirectories, 'i'gnore errors my $s =shift; my $opt =$_[0] =~/^\-/ || $_[0] eq '' ? shift : ''; my $ret =1; $s->logRec('pthRm',$opt,@_); foreach my $par (@_) { foreach my $e ($s->pthGlob($par)) { if (-d $e) { if ($opt =~/r/i && !$s->pthRm($opt,"$e/*")) { $ret =0 } elsif (!rmdir($e)) { $ret =0; $opt =~/i/i || return(&{$_[0]->{-die}}($s->lng(0, 'pthRm') .": rmdir('$e') -> $!" .$_[0]->{-ermd})||0); } } elsif (-f $e && !unlink($e)) { $ret =0; $opt =~/i/i || return(&{$_[0]->{-die}}($s->lng(0, 'pthRm') .": unlink('$e') -> $!" .$s->{-ermd})||0); } } } $ret } sub pthCln { # Clean unused (empty) directory return(0) if !-d $_[1]; my ($s, $d) =@_; my @g =$s->pthGlob("$d/*"); return(0) if scalar(@g) >1 || scalar(@g) ==1 && $g[0] !~/\.htaccess$/i; foreach my $f (@g) { unlink($f) }; while ($d && rmdir($d)) { $d =($d =~m/^(.+)[\\\/][^\\\/]+$/ ? $1 : '') }; !-d $d } sub pthCp { # Copy filesystem path # -'d'irectory or 'f'ile hint; 'r'ecurse subdirectories, 'i'gnore errors my $s =shift; my $opt =$_[0] =~/^-/i ? shift : ''; my ($src,$dst) =@_; $opt =~s/-//g; if ($^O eq 'MSWin32' && (eval{Win32::IsWinNT} ||(($ENV{OS}||'') =~/Windows_NT/i))) { $src =~tr/\//\\/; $dst =~tr/\//\\/; $opt ="${opt}Z"; $opt ="${opt}Y" if (eval{(Win32::GetOSVersion())[1]} ||0) >=5 } elsif ($^O eq 'MSWin32') { $src =~tr/\//\\/; $dst =~tr/\//\\/ } if ($^O ne 'MSWin32' && $^O ne 'dos') { $opt =~ tr/fd//; $opt ="-${opt}p"; $opt =~ tr/ri/Rf/; $s->osCmd('cp', $opt, @_) } else { my $rsp =($opt =~/d/i ? 'D' : $opt =~/f/i ? 'F' : ''); $opt =~s/(r)/SE/i; $opt =~s/(i)/C/i; $opt =~s/[fd]//ig; $opt =~s/(.{1})/\/$1/gi; my @cmd =('xcopy.exe',"/H/R/K/Q$opt","\"$src\"","\"$dst\""); push @cmd, sub{CORE::print($rsp)} if $rsp && ($ENV{OS} && ($ENV{OS}=~/Windows_NT/i) ? !-e $dst : !-d $dst); $s->osCmd(@cmd) } } ######################################################### # Variables & Logging Methods ######################################################### sub varFile { # Common variables filename $_[0]->pthForm('var','var.pl'); } sub varLoad { # Load common variables my ($s, $lck) =@_; return($s->{-var}) if $s->{-var} && !$lck; $s->{-var}->{'_handle'}->destroy if $s->{-var} && $s->{-var}->{'_handle'}; $s->{-var} =undef; my $fn =$s->varFile; my $hf; if (!-f $fn) { $s->{-var} ={'id'=>'DBIx-Web-variables'}; $s->varStore(); } # $s->logRec('varLoad', $lck ? ($lck) : (LOCK_SH, $lck)); $hf =$s->hfNew('+<',$fn)->lock($lck||LOCK_SH); $s->{-var} =$hf->{-buf} =$hf->load && $s->dsdParse($hf->{-buf}); $s->{-var}->{'_handle'} =$hf; if (!$lck) { # $hf->lock(LOCK_UN |LOCK_NB); # $hf->close(); # auto LOCK_UN, auto reopen $hf->destroy(); delete $s->{-var}->{'_handle'}; } $s } sub varLock { # Lock common variables file if (!$_[0]->{-var} ||!$_[0]->{-var}->{'_handle'}) { $_[0]->varLoad($_[1] ||LOCK_EX) } elsif ((($_[1] ||LOCK_EX) eq LOCK_EX) && (($_[0]->{-var}->{'_handle'}->{-lock} ||0) ne LOCK_EX) ){ $_[0]->varLoad($_[1] ||LOCK_EX) } else { # $_[0]->logRec('varLock',$_[1] ||LOCK_EX); $_[0]->{-var}->{'_handle'}->lock($_[1] ||LOCK_EX) } } sub varStore { # Store common variables my $s =shift; my $hf = !$s->{-var} ||!$s->{-var}->{'_handle'} ? $s->hfNew('+>',$s->varFile) : $s->{-var}->{'_handle'}; delete($s->{-var}->{'_handle'}); $hf->lock(LOCK_EX)->store($s->dsdMk($s->{-var}))->close(); $hf->{-buf} =$s->{-var}; $s->{-var}->{'_handle'} =$hf; $s } sub logOpen { # Log File open return($_[0]->{-log}) if ref($_[0]->{-log}); my $fn =$_[0]->pthForm('log','cmdlog.txt'); $_[0]->{-log} =$_[0]->hfNew('+>>', $fn); $_[0]->{-log}->select(sub{$|=1}); $_[0]->{-log} } sub logLock { # Log File lock $_[0]->logOpen if !ref($_[0]->{-log}); $_[0]->{-log}->lock(@_[1..$#_]); } sub logRec { # Add record to log file return(1) if !$_[0]->{-log} && !$_[0]->{-logm}; $_[0]->logOpen() if $_[0]->{-log} && !ref($_[0]->{-log}); $_[0]->{-log}->print(strtime($_[0]),"\t" ,$_[0]->{-c} && $_[0]->{-c}->{-user} ||'unknown' ,"\t",logEsc($_[0],@_[1..$#_]),"\n") if $_[0]->{-log}; $_[0]->{-c}->{-logm} =[] if $_[0]->{-logm} && !$_[0]->{-c}->{-logm}; splice @{$_[0]->{-c}->{-logm}}, 2, 2, '...' if $_[0]->{-logm} && scalar(@{$_[0]->{-c}->{-logm}}) >$_[0]->{-logm}; push @{$_[0]->{-c}->{-logm}}, $_[0]->logEsc('(' .($TW32 ? (Win32::GetTickCount() -$TW32)/1000 : (time()-$^T)) .') '. $_[1], @_[2..$#_]) if $_[0]->{-logm}; 1 } sub logEsc { # Escape list for logging my $s =$_[0]; my $b =" "; my $r =$_[1] .$b; for (my $i=2; $i <=$#_; $i++) { my $v =$_[$i]; $r .= ( !defined($v) ? 'undef,' : ref($v) eq 'ARRAY' ? '[' .join(', ' ,map {strquot($s, $_); } @$v) .'],' : isa($v,'HASH') ? '{' .join(', ' ,map {(defined($_) && $_ =~/^-\w+[\d\w]*$/ ? $_ : strquot($s, $_)) .'=>' .strquot($s, $v->{$_}) } sort keys %$v) .'},' : $v =~/^\d+$/ ? $v .',' : $v =~/^-\w+[\d\w]*$/ ? $v .'=>' : ($i ==2) &&($_[1] =~/^dbi/) &&($v =~/^(?:select|insert|update|delete|drop|commit|rollback|fetch)\s+/i) ? $v .';' : ($i ==2) &&($_[1] =~/^dbi/) &&($v =~/^(?:keDel|kePut|affected|single|fetch)\b/i) ? $v : (strquot($s, $v) .',')) .$b } $r =~/^(.+?)[\s,;=>]*$/ ? $1 : $r } ######################################################### # User & Group names methods ######################################################### sub user { # current user name return($_[0]->{-userln} ? userln(@_) : $_[0]->{-c}->{-user}) if $_[0]->{-c}->{-user}; $_[0]->{-c}->{-user} = $_[0]->{-user} ? (ref($_[0]->{-user}) ? &{$_[0]->{-user}}(@_) : $_[0]->{-user}) : $_[0]->{-unames} ? $_[0]->unames->[0] : $_[0]->{-tn}->{-guest}; $_[0]->{-c}->{-user} = $_[0]->{-usernt} ? ($_[0]->{-c}->{-user} =~/^([^\@]+)\@(.+)$/ ? $2 .'\\' .$1 : $_[0]->{-c}->{-user}) : ($_[0]->{-c}->{-user} =~/^([^\\]+)\\(.+)$/ ? $2 .'@' .$1 : $_[0]->{-c}->{-user}); #$_[0]->logRec('user', $_[0]->{-c}->{-user}); $_[0]->{-userln} ? userln(@_) : $_[0]->{-c}->{-user} } sub userln { # current user local name return($_[0]->{-c}->{-userln}) if $_[0]->{-c}->{-userln}; my $s =$_[0]; my $un=$s->{-c}->{-user} ||$s->user(); my ($d, $u) = $un =~/^([^\\]+)\\(.+)$/ ? ($1, $2) : $un =~/^([^\@]+)\@(.+)$/ ? ($2, $1) : ('', $un); $s->{-c}->{-userln} = !$d ? $u : $^O eq 'MSWin32' && lc($d) eq lc($s->w32domain()) ? $u : eval('use Sys::Hostname; Sys::Hostname::hostname()') =~/\Q$d\E$/i ? $u : $un } sub uguest { # is current user a guest lc($_[0]->user()) eq lc($_[0]->{-tn}->{-guest}) } sub unames { # current user names return($_[0]->{-c}->{-unames}) if $_[0]->{-c}->{-unames}; $_[0]->{-c}->{-unames} = $_[0]->{-unames} ? (ref($_[0]->{-unames}) ? &{$_[0]->{-unames}}(@_) : $_[0]->{-unames}) : $_[0]->{-user} ? [$_[0]->user() , !defined($_[0]->{-usernt}) && ($_[0]->user() =~/^([^\\@]+)([\\@])([^\\@]+)$/) ? ($2 eq '@' ? "$3\\$1" : "$3\@$1") : () , $_[0]->user() ne $_[0]->userln() ? ($_[0]->userln()) : () ] : [$_[0]->{-tn}->{-guest}]; $_[0]->logRec('unames', $_[0]->{-c}->{-unames}); $_[0]->{-c}->{-unames} } sub ugroups { # user groups # (self, ?user) -> [user's groups] return($_[0]->{-c}->{-ugroups}) if !$_[1] && $_[0]->{-c}->{-ugroups}; if ($_[0]->{-ugroups}) { return($_[0]->{-c}->{-ugroups} =ref($_[0]->{-ugroups}) eq 'CODE' ? &{$_[0]->{-ugroups}}(@_) : $_[0]->{-ugroups}) } my $s =$_[0]; my $un=$_[1] ||$s->user(); my $ul=$_[1] ||$s->userln(); my $ug=undef; my $fn=undef; my $rs=''; my $rl=''; if (($fn =$s->{-AuthGroupFile} || (( ($s->{-ldap} && $s->ugfile('ugf_ldap')) || ($s->{-w32ldap} && $s->ugfile('ugf_w32ldap')) || (($^O eq 'MSWin32') && $s->ugfile('ugf_w32')) ) && $s->pthForm('var','uagroup') ) ) && -f $fn) { my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH); $ug =[]; while(my $r =$fh->readline()) { next if $r !~/[:\s](?:\Q$un\E|\Q$ul\E)(?:\s|\Z)/i; next if $r !~/^([^:]+):/; push @$ug, $1 } $fh->close(); $ug =undef if !@$ug; } elsif (0 # lost code, for example && $s->{-ldap}) { $ug =$s->ldapUgroups($un); $ug =undef if $ug && !@$ug; } if ($ug) { $rl ='file'; $un =($rs =~/^([^:]+):/ ? $1 : $rs) if $rs; # !!! not used } else { $rl ='default'; $ug =$s->{-ugadd} ? [] : [$s->{-tn}->{-guests}, $s->uguest ? () : ($s->{-tn}->{-users})]; } if (!defined($s->{-usernt})) { } elsif ($s->{-usernt}) { $ug =[map {$_ =~/\@/ ? () : $_ } @$ug] } else { $ug =[map {$_ =~/\\/ ? () : $_ } @$ug] } if ($s->{-ugflt}) { my $fg =$s->{-ugflt}; $ug =[map {&$fg($s,$_) ? ($_) : () } @$ug] } if ($s->{-ugadd}) { local $_ =$ug; my $ugadd=ref($s->{-ugadd}) eq 'CODE' ? &{$s->{-ugadd}}($s) : $s->{-ugadd}; foreach my $e ( ref($ugadd) eq 'ARRAY' ? @{$ugadd} : ref($ugadd) eq 'HASH' ? keys(%$ugadd) : $ugadd){ push @$ug, $e if defined($e) && !grep /^\Q$e\E$/i, @$ug; } } if ($s->{-ugflt1}) { local $_ =$un; &{$s->{-ugflt1}}($s, $un, $ul, $ug); } $s->logRec('ugroups', $un, $rl, $ug) if $rl; $s->{-c}->{-ugroups} =$ug if !$_[1]; $ug } sub ugnames { # current user and group names # (self, ?user) -> [user's names] if ($_[1]) { # return([$_[1]]); local $_[0]->{-userln} =0; local $_[0]->{-c}->{-user} =$_[1]; local $_[0]->{-c}->{-userln} =undef; local $_[0]->{-c}->{-ugroups} =undef; local $_[0]->{-c}->{-unames} =undef; local $_[0]->{-c}->{-ugrexp} =undef; local $_[0]->{-c}->{-ugnames} =undef; my $r =$_[0]->ugnames(); return($r) } elsif ($_[0]->{-c}->{-ugnames}) { return($_[0]->{-c}->{-ugnames}) } $_[0]->{-c}->{-ugnames} =[map {$_} @{$_[0]->unames()}, map {$_} @{$_[0]->ugroups()}] } sub ugrexp { # current user and group names regexp source return($_[0]->{-c}->{-ugrexp}) if $_[0]->{-c}->{-ugrexp}; my $n =join('|', @{$_[0]->ugnames()}); $n =~s/([\\.?*\$\@])/\\$1/g; $_[0]->{-c}->{-ugrexp} =eval('sub{(($_[0]=~/(?:^|,|;)\\s*(' .$n .')\\s*(?:,|;|$)/i) && $1)}') } sub ugmember { # user group membership my $e =$_[0]->{-c}->{-ugrexp} ||ugrexp($_[0]); foreach my $i (@_[1..$#_]) { if (ref($i)) {foreach my $j (@$i) {defined($j) && &$e($j) && return(1)}} else {defined($i) && &$e($i) && return(1)} } undef } sub uadmin { # user admin groups membership uadmwtr(@_) } sub uadmwtr { # user admin writer groups membership return($_[0]->{-c}->{-uadmwtr}) if exists($_[0]->{-c}->{-uadmwtr}); $_[0]->{-c}->{-uadmwtr} =$_[0]->{-racAdmWtr} && ugmember($_[0], $_[0]->{-racAdmWtr}) } sub uadmrdr { # user admin reader groups membership return($_[0]->{-c}->{-uadmrdr}) if exists($_[0]->{-c}->{-uadmrdr}); $_[0]->{-c}->{-uadmrdr} =$_[0]->{-racAdmRdr} && ugmember($_[0], $_[0]->{-racAdmRdr}) } sub uglist { # User & Group List my $s =shift; # self, '-ug<>dc', ?user|group|filter, ?container my $o =defined($_[0]) && substr($_[0],0,1) eq '-' ? shift : '-ug'; my $fc=ref($_[0]) eq 'CODE' ? shift : undef; my $fm=ref($_[0]) ? undef : $_[0] && $o !~/u/ ? [map {lc($_)} @{$s->ugroups(shift)}] : shift; my $fg=$s->{-ugflt}; my $fu=$s->{-unflt}; my $r =shift ||[]; my $fn=undef; local $_; if ($s->{-uglist}) { $r =&{$s->{-uglist}}($s, $o, $r) } elsif ($s->{-AuthUserFile} ||$s->{-AuthGroupFile}) { my @r; my $en; $fn =$s->{-AuthGroupFile}; if ($fm && !ref($fm) && -f $fn) { my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH); while(my $r =$fh->readline()) { next if $r !~/^\Q$fm\E:/i; $r =$'; chomp($r); $fm =[map {lc($_)} split /[\t]+/, $r]; last; } $fh->close(); return($r) if !ref($fm) || !@$fm; } $fm =undef if $fm && (!ref($fm) || !@$fm); $fn =$s->{-AuthUserFile}; if ($o =~/u/ && $fn && -f $fn) { my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH); while(my $r =$fh->readline()) { next if $r !~/^([^:]+):/; $en =$_ =$1; next if $fu && !&$fu($s,$en) || $fc && !&$fc($s,$en); if ($fm) { my($el, $rl) =(lc($en), undef); foreach my $e (@$fm) {if ($el eq $e) {$rl =$el; last}}; next if !$rl; } push @r, $en; } $fh->close() } $fn =$s->{-AuthGroupFile}; if ($o =~/g/ && $fn && -f $fn) { my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH); while(my $r =$fh->readline()) { next if $r !~/^([^:]+):/; $en =$_ =$1; next if $fg && !&$fg($s,$en) || $fc && !&$fc($s,$en); if ($fm) { my($el, $rl) =(lc($en), undef); foreach my $e (@$fm) {if ($el eq $e) {$rl =$el; last}}; next if !$rl; } push @r, $en; } $fh->close() } $r =ref($r) eq 'HASH' ? {map {($_ => $_)} @r} : [@r] } elsif (( ($s->{-ldap} && $s->ugfile('ugf_ldap')) ||($s->{-w32ldap} && $s->ugfile('ugf_w32ldap')) ||($^O eq 'MSWin32' && $s->ugfile('ugf_w32')) ) && ($fn =$s->pthForm('var','ualist')) && -f $fn) { my $dn=!$s->{-userln} && (!($s->{-ldap}) && ($^O eq 'MSWin32') && $s->w32domain()); # see ugfile() for domain name qualifications if ($fm && !ref($fm)) { my $fn=$s->pthForm('var','uagroup'); my $vn=!$dn ? $fm : $fm =~/^\Q$dn\E\\/i ? $' : $fm =~/\@\Q$dn\E$/i ? $` : $fm; if (-f $fn) { my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH); while(my $rr =$fh->readline()) { next if $rr !~/^\Q$vn\E:/i; $rr =$'; chomp($rr); $fm =[map {lc($_)} split /[\t]+/, $rr]; last; } $fh->close() } return($r) if !ref($fm) || !scalar(@$fm); } my $fh=$s->hfNew('<', $fn)->lock(LOCK_SH); while(my $rr =$fh->readline()) { my ($en, $ef, $ep, $ec, $ed, $em, $ei) =(split /:\t/, $rr); #[0,1,2,3,4,5,6]; # name, fullname, path, class, display, email, description if ($fc) {next if !&$fc($s, $en, $ef, $ep, $ed, $em, $ei)} elsif ($fm) { my($el, $rl) =(lc($en), undef); foreach my $e (@$fm) {if ($el eq $e) {$rl =$el; last}}; next if !$rl; } $en =$s->{-usernt} ? ($en =~/[\\]/ ? $en : $en =~/^([^\@]+)\@([^\@]+)$/ ? "$2\\$1" : $dn && ($ef=~/\@/) ? "$dn\\$en" : $en) : ($en =~/[@]/ ? $en : $en =~/^([^\\]+)\\([^\\]+)$/ ? "$2\@$1" : $dn && ($ef=~/\@/) ? "$en\@$dn" : $en); my $ev =($en =~/[\@\\]/ && $o !~/[<>]/ ? $ef : $en); $en =lc($en) if $o =~/d/; $_ =$en; if ($o =~/g/ && $ec =~/^g/i) { next if $fg && !&$fg($s, $en, $ef, $ep, $ed, $em, $ei); if (ref($r) eq 'ARRAY') { push(@$r, $en) } elsif ($ed) { $r->{$en} = $o =~/d/ ? $ed : ($ed.' <' .$ev .'>') } else { $ed =$ei ||$ef if !$ed; $r->{$en} = !$ed ? $ev : $ed =~/^\Q$en\E\s*([,.-:]*)\s*(.*)/i ? $ev .(!$2 || ($o =~/d/) ? '' : (($1 ? " $1 " : ' - ') .$2)) : ($o =~/d/) && ($o =~/c/) ? $ed : $o =~/[<>]/ ? (length($ed)+length($ev)+3 >60 ? substr($ed, 0, 60 -length($ev)-6) .'...' : $ed) .' <' .$ev .'>' : "$ev, $ed"; $r->{$en} =substr($r->{$en},0,60-3) .'...' if length($r->{$en}) >60 -3; } } if ($o =~/u/ && $ec =~/^u/i) { next if $fu && !&$fu($s, $en, $ef, $ep, $ed, $em, $ei); if (ref($r) eq 'ARRAY') { push(@$r, $en) } else { $r->{$en} = $o =~/d/ ? $ed ||$ef : (($ed ||$ef).' <' .$ev .'>') } } } $fh->close(); } elsif (0 && $s->{-ldap}) { # lost code, for example $r =$s->ldapLst($o, $fc||$fm||'', $r); } else { } if ($s->{-ugadd} && $r && ($o =~/g/)) { local $_ =$r; my $ugadd=ref($s->{-ugadd}) eq 'CODE' ? &{$s->{-ugadd}}($s) : $s->{-ugadd}; if ((ref($ugadd) eq 'HASH') && (ref($r) eq 'HASH')) { foreach my $e (keys(%$ugadd)) { $r->{$e} =$ugadd->{$e} if !$r->{$e}; } } else { foreach my $e ( ref($ugadd) eq 'ARRAY' ? @{$ugadd} : ref($ugadd) eq 'HASH' ? keys(%$ugadd) : $ugadd){ if (ref($r) eq 'HASH') { $r->{$e} =$e if !$r->{$e} } else { push @$r, $e if !grep /^\Q$e\E$/i, @$r } } } } $r =do{use locale; [sort {lc($a) cmp lc($b)} @$r]} if ref($r) eq 'ARRAY'; $r } sub udisp { # display user name !defined($_[1]) || $_[1] eq '' ? '' : $_[0]->{-AuthUserFile} ? $_[1] : $_[0]->{-c}->{-udisp} ? $_[0]->{-c}->{-udisp}->{lc($_[1])} ||(($^O eq 'MSWin32') && w32udisp(@_)) ||$_[1] : ref($_[0]->{-udisp}) ? do { my $v =&{$_[0]->{-udisp}}(@_); if (ref($v)) { $_[0]->{-c}->{-udisp} =$v; $v =$_[0]->{-c}->{-udisp}->{lc($_[1])} } $v ||(($^O eq 'MSWin32') && w32udisp(@_)) ||$_[1] } : do { $_[0]->{-c}->{-udisp} =$_[0]->uglist( (!$_[0]->{-udisp} ? '-ud' : $_[0]->{-udisp} =~/\w/ ? '-ud' .$_[0]->{-udisp} : '-ugdc') , {}); $_[0]->{-c}->{-udisp}->{lc($_[1])} ||(($^O eq 'MSWin32') && w32udisp(@_, !$_[0]->{-udisp} ? () : $_[0]->{-udisp} =~/\w/ ? '-ud' .$_[0]->{-udisp} : '-ugdc')) ||$_[1] } } sub udispq { # display user name quick !defined($_[1]) || $_[1] eq '' ? '' : $_[0]->{-AuthUserFile} ? $_[1] : $_[0]->{-c}->{-udisp} ? $_[0]->{-c}->{-udisp}->{lc($_[1])} ||$_[1] : ref($CACHE) && $CACHE->{-udisp} ? $CACHE->{-udisp}->{lc($_[1])} ||$_[1] : (do{ my $v =udisp(@_); $CACHE->{-udisp} =$_[0]->{-c}->{-udisp} if ref($CACHE); $v}) } sub ugfile { # Users/groups caching, 'AuthGroupFile' file write/refresh # (?self, call, filesystem, mandatory op, args) my ($s, $call, $fs, $mo, @arg) =@_; $fs =$s->pthForm('var') if !$fs; # filesystem my $fg =$fs .'/' .'uagroup'; # file 'group' my $fl =$fs .'/' .'ualist'; # file list return(1) # update frequency if (-f $fg) && (time() -[stat($fg)]->[9] <60*60*4); @arg = $call eq 'ugf_w32' # call args ? ($s->{-udflt} ||sub{1}) # domain filter sub{}() : $call eq 'ugf_w32ldap' ? ($s->{-w32ldap}) # adsi ldap [[?domain=>path],...] : $call eq 'ugf_ldap' ? () # ldap support : () if ref($_[0]) && !$mo; if (!$mo) { # check mode if (!-f $fg) { # immediate interactive $s->logRec('ugfile','new',$fg); } elsif ($mo =$s && $s->{-endh}) {# end request handlers $s->logRec('ugfile','queue','uagroup',stat($fg)) if !$mo->{ugfile}; $mo->{ugfile} =sub{ugfile($_[0],$call,$fs,'q',@arg)}; return(1) } } elsif ($mo eq 'q') { # queued mode if (ref($_[0]) # reverted reject && $_[0]->{-w32IISdpsn} && ($_[0]->{-w32IISdpsn} <2) && $_[0]->{-c}->{-RevertToSelf}) { return(0) } elsif (1) { # inline } elsif (eval("use Thread; 1") # threads && ($mo =eval{Thread->new(sub{ugfile($call=~/^(?:ugf_ldap)$/ ? $s : undef , $call, $fs, 't', @arg)})}) ) { $s->logRec('ugfile','thread',$mo); $mo->detach; return(1); } elsif ($mo =fork) { # fork parent success $SIG{CHLD} ='IGNORE'; $s->logRec('ugfile','fork',$mo); return(1); } elsif (!defined($mo)) { # fork error, immediate interactive } else { # fork child $mo ='f'; ugfile($call=~/^(?:ugf_ldap)$/ ? $s : undef , $call, $fs, $mo, @arg); exit(0); } } my @tm=(time()); local(*FG, *FL, *FW); open(FG, "+>>$fg.tmp") || ($s && &{$s->{-die}}($s->lng(0, 'ugfile') .": open('$fg.tmp') -> $!" .$s->{-ermd})) || croak("open('<$fg.tmp') -> $!"); open(FL, "+>>$fl.tmp") || ($s && &{$s->{-die}}($s->lng(0, 'ugfile') .": open('$fl.tmp') -> $!" .$s->{-ermd})) || croak("open('<$fl.tmp') -> $!"); while (!flock(FG,LOCK_EX|LOCK_NB) ||!flock(FL,LOCK_EX|LOCK_NB)) { next if !-f $fg; flock(FG,LOCK_UN); close(FG); flock(FL,LOCK_UN); close(FL); return(1) } truncate(FG,0); truncate(FL,0); seek(FG,0,0); seek(FL,0,0); if ($call eq 'ugf_w32') {ugf_w32 ($s, \*FG, \*FL, \@tm, @arg)} elsif ($call eq 'ugf_w32ldap'){ugf_w32ldap($s, \*FG, \*FL, \@tm, @arg)} elsif ($call eq 'ugf_ldap') {ugf_ldap($s, \*FG, \*FL, \@tm, @arg)} # my ($s, $tm, $df); # local (*FG, *FL); # ($s, *FG, *FL, $tm, @arg) =@_; # ualist/ugf_w32, used in uglist(), ":\t" delimited: # domain?\user : user@domain : ADsPath : 'User' : FullName : email : Description # domain?\group: group@domain: ADsPath : 'Group': : email : Description : members # uagroup/ugf_w32, used in uglist(), "\t" delimited: # ?group : members # ?name domain\name name@domain # domain\group : members # group@domain : members # # ugf_w32, used in uglist(): # standalone host: local users, local groups # domain member: domain users, local member groups, domain groups # domain controller: domain users, local domain groups, domain groups # local member groups unqualified always (using simple 'fullname' without '@') # local controller groups unqualified usually seek(FG,0,0); seek(FL,0,0); open(FW, "+>>$fg") && flock(FW,LOCK_EX) && truncate(FW,0) && seek(FW,0,0) && (do {while(my $rr =readline *FG){print FW $rr}; 1}) && flock(FW,LOCK_UN) && close(FW) || ($s && $s->die($s->lng(0, 'ugfile') .": open('$fg') -> $!")) || croak("open('<$fg') -> $!"); flock(FG,LOCK_UN); close(FG); unlink("$fg.tmp"); open(FW, "+>>$fl") && flock(FW,LOCK_EX) && truncate(FW,0) && seek(FW,0,0) && (do {while(my $rr =readline *FL){print FW $rr}; 1}) && flock(FW,LOCK_UN) && close(FW) || ($s && $s->die($s->lng(0, 'ugfile') .": open('$fl') -> $!")) || croak("open('<$fl') -> $!"); flock(FL,LOCK_UN); close(FL); unlink("$fl.tmp"); push @tm, time(); $s->logRec('ugfile','timing',join('-', map {$tm[$_] -$tm[$_-1]} (1..$#tm)),'sec') if $s; 1; } sub ugf_w32 { # ugfile() module using Win32 ADSI WinNT:// my ($s, $FG, $FL, $tm, $df) =@_; eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0); my $od =Win32::OLE->GetObject('WinNT://' .(Win32::NodeName()) .',computer'); my $hdu=$od && $od->{Name} || ''; # host domain name my $hdn=$od && lc($od->{Name}) || ''; # host domain name my $hdp=$od && $od->{ADsPath} || ''; # host domain path my $hdc=lc($hdp); # host domain comparable my $ldp=$od && $od->{Parent} || ''; # local domain path $od =Win32::OLE->GetObject("$ldp,domain"); my $ldu=$od && $od->{Name} || ''; # local domain name my $ldn=$od && lc($od->{Name}) || ''; # local domain name my $ldc=lc($ldp); # local domain comparable my $lds =$ldu && w32isDC($s) && $ldn || ''; # local DC service? $s->logRec('ugfile','ugf_w32','host',$hdp,'dc',$lds,'domain',$ldp) if $s; my %dnl=(!$hdn ||$lds ?() :($hdn=>1), !$ldn ?() :($ldn=>1)); # domains to list my @dnl=(!$hdu ||$lds ?() :$hdu, !$ldu ?() :$ldu); # domains to list my $fgm; # group lister/unfolder $fgm=sub{ my $om =$_[1]->{Members}; join("\t" ,(map {!$_ || !$_->{Class} || !$_->{Name} || substr($_->{Name},-1,1) eq '$' || substr($_->{Name},-1,1) eq '&' ? () : do { my $dn =$_->{Parent} =~/([^\\\/]+)$/ ? $1 : $_->{Parent}; map {$_ # $_ ne lc($_) ? ($_, lc($_)) : $_ } lc($_->{Parent}) ne ($ldn ? $ldc : $hdc) ? ($dn . '\\' .$_->{Name}) : ($_->{Name}, ($dn . '\\' .$_->{Name})) , $_->{Name} .'@' .$dn }} do {$om->{Filter} =['User']; Win32::OLE::in($om)}) ,(map {!$_ || !$_->{Class} || !$_->{Name} || !$_->{groupType} || substr($_->{Name},-1,1) eq '$' || substr($_->{Name},-1,1) eq '&' ? () : do { if ($_->{groupType} eq '2') { # 2 -global; 8 -universal my $du =$_->{Parent} =~/([^\\\/]+)$/ ? $1 : $_->{Parent}; my $dn =lc($du); if (!$dnl{$dn} && $dn !~/^(?:nt authority|builtin)$/) { $dnl{$dn} =1; push @dnl, $du; } } (&$fgm($_[0], $_)) }} do {$om->{Filter} =['Group']; Win32::OLE::in($om)}) )}; for (my $di =0; $di <=$#dnl; $di++) { my $du =$dnl[$di]; local $_ =$du; next if !$du ||!&$df($s, $du); push @$tm, time(); $s->logRec('ugfile','ugf_w32','domain',$du) if $s; my $dn =lc($du); $od =Win32::OLE->GetObject("WinNT://$du"); next if !$od || !$od->{Class}; # standalone host: local users, local groups # domain member : domain users, local member groups, domain groups # domain controller: domain users, local domain groups, domain groups my $dp =$dn eq $ldn || $dn eq $hdn ? '' : $du; unless ($hdn && $ldn && ($dn eq $hdn)) { $od->{Filter} =['User']; # omited default domain part foreach my $oe (Win32::OLE::in($od)) { next if !$oe || !$oe->{Class} || !$oe->{Name} || substr($oe->{Name},-1,1) eq '$' || substr($oe->{Name},-1,1) eq '&'; next if $oe->{AccountDisabled}; next if $oe->{Name} =~/^(?:SYSTEM|INTERACTIVE|NETWORK|IUSR_|IWAM_|HP ITO |opc_op|patrol|SMS |SMS&_|SMSClient|SMSServer|SMSService|SMSSvc|SMSLogon|SMSInternal|SMS Site|SQLDebugger|sqlov|SharePoint|RTCService)/i; print $FL $dp ? "$dp\\" : '', $oe->{Name} ,":\t", $oe->{Name} .'@' .$du ,":\t", $oe->{ADsPath} ,":\t", $oe->{Class} ,":\t", $oe->{FullName}||'' ,":\t", '' ,":\t", $oe->{Description}||'' , "\n"; } } unless (0) { $od->{Filter} =['Group']; foreach my $oe (Win32::OLE::in($od)) { next if !$oe || !$oe->{Class} || !$oe->{Name} || substr($oe->{Name},-1,1) eq '$' || substr($oe->{Name},-1,1) eq '&'; next if ($dn ne ($lds ||$hdn)) && ($oe->{groupType} eq '4'); # local next if $oe->{Name} =~/^(?:Domain Controllers|Domain Computers|Pre-Windows 2000|RAS and IAS Servers|MTS Trusted|SMSInternal|NetOp Activity)/i; my $sgm =&$fgm($_[0], $oe); print $FL $dp ? "$dp\\" : '', $oe->{Name} ,":\t", $oe->{Name} .(($oe->{groupType} ne '4') ? '@' .$du : '') ,":\t", $oe->{ADsPath} ,":\t", $oe->{Class} ,":\t", '' ,":\t", '' ,":\t", $oe->{Description}||'' , "\n"; print $FG !$dp ? ($oe->{Name}, ":\t", $sgm, "\n") : () , $du, '\\', $oe->{Name}, ":\t", $sgm, "\n" , $oe->{Name}, '@', $du, ":\t", $sgm, "\n" ; } } } 1 } sub ugf_w32ldap { # ugfile() module using Win32 ADSI LDAP:// and WinNT:// my ($s, $FG, $FL, $tm, $aq) =@_; my $hn ={}; # dn -> name my $hm ={}; # group dn -> members eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0); my $ll =w32isDC($s); # local DC my $ld =w32domain($s); my $lh =Win32::NodeName(); my $ae; $ae =sub{ foreach my $oe (Win32::OLE::in($_[0])) { if (!ref($oe) ||!$oe->{Class} ||!($oe->{cn} ||$oe->{Name})) { } elsif ($oe->{Class} =~/^(?:container|organizationalUnit|builtinDomain)$/i) { &$ae($oe, @_[1..$#_]) } elsif (($oe->{cn} ||$oe->{Name} ||'') =~/\$$/) { } elsif ($oe->{Class} =~/^(?:user|group)$/i) { &{$_[1]}($oe) } } }; my $am; $am =sub{ return('') if !$hm->{$_[0]}; my $hg =$_[1] ||{}; join("\t" , map { if ($hg->{$_}) { () } elsif (!$hm->{$_}) { $hg->{$_} =1; my $v =$hn->{$_} ||$_; $v =~/^$ld\\/i ? ($',$v,"$'\@$ld") : $v =~/\\/ ? ($v, "$'\@$`") : $ll ? ($v, "$ld\\$v", "$v\@$ld") : ($v) } else { $hg->{$_} =1; my $v =$hn->{$_} ||$_; my $a =&$am($_, $hg); (($v =~/^$ld\\/i ? ($',$v,"$'\@$ld") : $v =~/\\/ ? ($v, "$'\@$`") : $ll ? ($v, "$ld\\$v", "$v\@$ld") : ($v)) ,$a ? $a : ()) }} @{$hm->{$_[0]}}) }; foreach my $e ($ll ? () : '', ref($aq) ? @$aq : $aq) { my ($pw, $pl) =ref($e) ? @$e : ('', $e); # $pw eq '' - local domain - $ld, 'LDAP://' # $ll - local DC, 'LDAP://' # $pl eq '' - local server - Win32::NodeName(), 'WinNT://' my $pi = $pl=~/\bDC=/ ? join('.', split /,DC=/, $') : ''; $s->logRec('ugfile', 'ugf_w32ldap', 'domain', $pw||$ld, $pi, $pl||$lh) if $s; my $od =$pl ? Win32::OLE->GetObject("LDAP://$pl") : Win32::OLE->GetObject("WinNT://$lh"); if (!ref($od)) { $s ? $s->warn("Win32::OLE->GetObject('LDAP://$pl') -> $@") : carp("Win32::OLE->GetObject('LDAP://$pl') -> $@"); next; } &$ae($od,sub{ my $oe =$_[0]; return(0) if !$oe->{GUID}; return(0) if $pl && ($pw || !$ll) && ($oe->{Class} =~/^(?:group)$/i) && (($oe->{groupType}||0) & 0x00000004); # ADS_GROUP_TYPE_LOCAL_GROUP my $id =($pl ? $oe->{GUID} : ($oe->{cn} ||$oe->{Name})); my $en =($pw ? $pw .'\\' : '') .($oe->{cn} ||$oe->{Name}); $hn->{$id} =$en; my $on =undef; # 'foreignSecurityPrincipal'->'foreignIdentifier' may be empty $hm->{$id} =[ map { if (!$_ ||!$_->{Class}) {()} elsif ($_->{Class} =~/^(foreignSecurityPrincipal)$/) { if ($oe->{foreignIdentifier}) { $oe->{foreignIdentifier} } else { $on =1; () } } else { $pl ? $_->{GUID} : (($_->{Parent}=~/([^\\\/]+)$/) && (lc($1) ne lc($lh)) ? "$1\\" : '') .($_->{cn} ||$_->{Name}); } } Win32::OLE::in($oe->{Members})] if $oe->{Class} =~/^(?:group)$/i; if ($on) { $on ='WinNT://' .($pw||$ld||$lh) .'/' .($oe->{cn}||$oe->{Name}); my $og =Win32::OLE->GetObject($on); return($s ? $s->warn("Win32::OLE->GetObject('$on') -> $@") : carp("Win32::OLE->GetObject('$on') -> $@") ) if !$og; $on =$hm->{$oe->{GUID}}; foreach my $om (Win32::OLE::in($og->{Members})) { # GUIDs different in 'WinNT://' and 'LDAP://'; GUID formats different also. # "User Naming Attributes": objectGUID is a 128-bit GUID structure stored as an OctetString. # typedef struct _GUID { DWORD Data1; WORD Data2; WORD Data3; BYTE Data4[8];} GUID; # my $k =$om->{GUID}; # next if grep /^\Q$k\E$/, @$on; # push @$on, $k; my $k = $om->{Parent}=~/([^\\\/]+)$/ ? $1 : '???'; push @$on, $k .'\\' .$om->{Name} if $k && (lc($k) ne lc($pw||$ld)); } } }); } foreach my $e ($ll ? () : '', ref($aq) ? @$aq : $aq) { my ($pw, $pl) =ref($e) ? @$e : ('', $e); my $pi = $pl=~/\bDC=/ ? join('.', split /,DC=/, $') : ''; $s->logRec('ugfile', 'ugf_w32ldap', 'domain', $pw ||$ld, $pi, $pl||$lh) if $s; my $od =$pl ? Win32::OLE->GetObject("LDAP://$pl") : Win32::OLE->GetObject("WinNT://$lh"); if (!ref($od)) { $s ? $s->warn("Win32::OLE->GetObject('LDAP://$pl') -> $@") : carp("Win32::OLE->GetObject('LDAP://$pl') -> $@"); next; } &$ae($od,sub{ my $oe =$_[0]; return(0) if !$oe->{GUID}; return(0) if !$pl && ($oe->{Class} =~/^(?:user)$/i); return(0) if $pl && ($pw || !$ll) && ($oe->{Class} =~/^(?:group)$/i) && (($oe->{groupType}||0) & 0x00000004); # ADS_GROUP_TYPE_LOCAL_GROUP my $id =($pl ? $oe->{GUID} : ($oe->{cn} ||$oe->{Name})); my $en =$hn->{$id} ||$oe->{cn} ||$oe->{Name}; return(0) if $en =~/^(?:Domain Controllers|Domain Computers|Pre-Windows 2000|RAS and IAS Servers|MTS Trusted|SMSInternal|NetOp Activity)/i; return(0) if $en =~/^(?:SYSTEM|INTERACTIVE|NETWORK|IUSR_|IWAM_|HP ITO |opc_op|patrol|SMS |SMS&_|SMSClient|SMSServer|SMSService|SMSSvc|SMSLogon|SMSInternal|SMS Site|SQLDebugger|sqlov|SharePoint|RTCService)/i; my $ef =($oe->{cn}||$oe->{Name}||'') .(!($oe->{Class} =~/^(?:group)$/i) || !($oe->{groupType} & 0x00000004) ? '@' .($pi ||$lh) : ''); my $el =&$am($id); print $FL $en ,":\t", $ef ,":\t", $oe->{ADsPath} ||'' ,":\t", ucfirst($oe->{Class}) ||'' ,":\t", $oe->{FullName} ||'' ,":\t", $oe->{EmailAddress} ||'' ,":\t", $oe->{Description} ||'' , "\n"; print $FG $en, ":\t", $el, "\n" if $el; print $FG "$ld\\$en", ":\t", $el, "\n" ,"$en\@$ld", ":\t", $el, "\n" if $el && !$pw && $pl; print $FG "$lh\\$en", ":\t", $el, "\n" ,"$en\@$lh", ":\t", $el, "\n" if $el && !$pw && !$pl; print $FG $ef, ":\t", $en , !$pw ? ("\t", "$ld\\$en") : () , $el ? ("\t", $el) : () , "\n" if $pl; }); } 1 } sub ugf_ldap { # ugfile() module using Net::LDAP my ($s, $FG, $FL, $tm, $ha) =@_; $s =$ha if !$s; my $hn ={}; # dn -> name my $hm ={}; # group dn -> members my $a =$ha && $ha->{-ldapattr} ||$s->{-ldapattr}; my $qf =($s->{-ldapfu} && $s->{-ldapfg} ? '(|' .$s->{-ldapfu} .$s->{-ldapfg} .')' : '' # : '(|(objectClass=organizationalPerson)(objectClass=groupOfNames))' ); $qf =$qf ? {'filter'=>$qf} : {}; my $q =$s->ldapSearch(%$qf); push @$tm, time(); for(my $i =0; $i < $q->count; $i++) { my $dn =$q->entry($i)->get_value('dn') ||$q->entry($i)->get_value('distinguishedName'); $hn->{$dn} =utf8dec($s, $q->entry($i)->get_value($a->[0])||''); $hm->{$dn} =[$q->entry($i)->get_value('member')] if $q->entry($i)->get_value('member'); } my $ae; $ae=sub{ return('') if !$hm->{$_[0]}; my $hg =$_[1] ||{}; join("\t" ,map { if ($hg->{$_}) { () } elsif (!$hm->{$_}) { $hg->{$_} =1; $hn->{$_} ? utf8dec($s, $hn->{$_}) : utf8dec($s, $_) } else { $hg->{$_} =1; my $a =&$ae($_, $hg); ($hn->{$_} ? utf8dec($s, $hn->{$_}) : () ,$a ? $a : ()) }} @{$hm->{$_[0]}}) }; push @$tm, time(); $q =$s->ldapSearch(%$qf); push @$tm, time(); for(my $i =0; $i < $q->count; $i++) { my $dn =$q->entry($i)->get_value('dn') ||$q->entry($i)->get_value('distinguishedName'); my $en =utf8dec($s, $q->entry($i)->get_value($a->[0])||''); my @en =$q->entry($i)->get_value($a->[0]); shift @en; my $ef =''; my $ep =utf8dec($s, $dn); my $em =utf8dec($s, $q->entry($i)->get_value('mail')||''); my $ec =utf8dec($s, $q->entry($i)->get_value('objectClass')||'') =~/person|user/i ? 'User' : 'Group'; my $ed =utf8dec($s, $q->entry($i)->get_value($a->[1]||$a->[0])||''); my $ei =utf8dec($s, $q->entry($i)->get_value('info')||''); $ei =join('; ', map {my $v =$q->entry($i)->get_value($_); !$v ? () : (utf8dec($s, $v)) } qw(title company department physicalDeliveryOfficeName telephoneNumber)) if !$ei; $ei =~s/[\n\r]/ /g; my $el =$hm->{$dn} ? &$ae($dn) : undef; print $FL $en ,":\t", $ef ||$em ||$en ||'' ,":\t", $ep ||'' ,":\t", $ec ||'' ,":\t", $ed ||'' ,":\t", $em ||'' ,":\t", $ei ||'' , "\n"; print $FG $en, ":\t", $el, "\n" if $el; print $FG map {utf8dec($s, $_) .":\t" .$en .($el ? "\t" .$el : '') ."\n" } @en if @en; } 1 } sub w32IISdpsn {# deimpersonate Microsoft IIS impersonated process # !!!Future: Problems may be. Implement '-fswtr' login also? # 'Win32::API' module used, not in ActiveState package. # Set 'IIS / Home Directory / Application Protection' = 'Low (IIS Process)' # or see 'Administrative Tools / Component Services'. # Do not use quering to 'Index Server'. # See also FastCGI for another ways: # http://php.weblogs.com/fastcgi_with_php_and_iis # http://www.caraveo.com/fastcgi/ # http://www.cpan.org/modules/by-module/FCGI/ return(undef) if (defined($_[0]->{-w32IISdpsn}) && !$_[0]->{-w32IISdpsn}) || $_[0]->{-c}->{-RevertToSelf} || ($^O ne 'MSWin32') || !(($ENV{SERVER_SOFTWARE}||'') =~/IIS/) # || $ENV{'GATEWAY_INTERFACE'} || $ENV{'FCGI_SERVER_VERSION'}; $_[0]->user(); $_[0]->{-c}->{-RevertToSelf} =1; my $o =eval('use Win32::API; new Win32::API("advapi32.dll","RevertToSelf",[],"N")'); my $l =eval{Win32::LoginName()} ||''; $o && $o->Call() && ($l ne (eval{Win32::LoginName()} ||'')) ? ($_[0]->{-debug}) && $_[0]->logRec('w32IISdpsn') : &{$_[0]->{-die}}($_[0]->lng(0, 'w32IISdpsn') .": Win32::API('RevertToSelf') -> " .join('; ', map {$_ ? $_ : ()} $@,$!,$^E) .$_[0]->{-ermd}) } sub w32adhi { # Win32 AD Host Info $_[0]->{'ADSystemInfo'} || ($_[0]->{'ADSystemInfo'} =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); Win32::OLE->CreateObject("ADSystemInfo")')) } sub w32domain { # Win32 domain name (or node name if no domain) w32adhi($_[0])->{DomainShortName} || eval{Win32::NodeName()} || $ENV{COMPUTERNAME} } sub w32isDC { # Win32 is on domain controller, not srvr or wrkstation eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0); Win32::OLE->GetObject('LDAP://' .Win32::NodeName()) && 1 } sub w32user { # Win32 user object eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0)'); my ($dn, $gn) = $_[1] =~/^([^\\]+)\\(.+)/ ? ($1,$2) : $_[1] =~/^([^@]+)@(.+)/ ? ($2,$1) : (Win32::NodeName(),$_); Win32::OLE->GetObject("WinNT://$dn/$gn"); } sub w32udisp { # Win32 user display name # (self, user, ?opt) return($_[1]) if $^O ne 'MSWin32'; return('') if !defined($_[1]) || $_[1] eq ''; my ($dn, $gn) = $_[1] =~/^([^\\]+)\\(.+)/ ? ($1,$2) : $_[1] =~/^([^@]+)@(.+)/ ? ($2,$1) : (Win32::NodeName(),$_[1]); my $o =eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0); 1') && Win32::OLE->GetObject("WinNT://$dn/$gn"); !$o ? $_[1] : $o->{Class} eq 'User' ? $o->{FullName} ||$_[1] : $_[2] && ($_[2] =~/c/) && ($o->{Class} eq 'Group') ? $o->{Description} ||$_[1] : $_[1] } sub w32ugrps { # Win32 user groups, optional usage, interesting legacy code my $uif =$_[1]; # user input full name my $uid =''; # user input domain name my $uin =''; # user input name shorten eval('use Win32::OLE'); Win32::OLE->Option('Warn'=>0); if ($uif =~/^([^\\]+)\\(.+)/) { $uid =$1; $uin =$2 } elsif ($uif =~/^([^@]+)\@(.+)/) { $uid =$2; $uin =$1 } else { $uin =$uif; $uid =Win32::OLE->CreateObject('ADSystemInfo')->{DomainShortName} ||Win32::NodeName()} my $gn =[]; # group names my $gp =[]; # group paths my $oh =Win32::OLE->GetObject('WinNT://' .Win32::NodeName() .',computer'); return($gn) if !$oh; my $ou =Win32::OLE->GetObject("WinNT://$uid/$uin,user"); return($gn) if !$ou; my $dp = # domain prefix for global groups, optional lc($oh->{Parent}) eq lc($ou->{Parent}) ? '' : $ou->{Parent} =~/([^\\\/]+)$/ ? $1 .'\\' : ''; foreach my $og (Win32::OLE::in($ou->{Groups})) { # global groups from user's domain next if !$og || !$og->{Class} || $og->{groupType} ne '2'; push @$gn, $dp .$og->{Name}; push @$gp, $og->{ADsPath}; } my $uc =lc($ou->{ADsPath}); # user compare my $gc =[map {lc($_)} @$gp]; # group compare $oh->{Filter} =['Group']; foreach my $og (Win32::OLE::in($oh)) { next if !$og || !$og->{Class} || $og->{groupType} ne '4'; foreach my $om (Win32::OLE::in($og->{Members})) { next if !$om || !$om->{Class} || ($om->{Class} ne 'User' && $om->{Class} ne 'Group'); my $mc =lc($om->{ADsPath}); foreach my $p (@$gc) { next if $p ne $mc; push @$gn, $og->{Name}; push @$gp, $og->{ADsPath}; $mc =undef; last; } last if !$mc; if ($mc eq $uc) { push @$gn, $og->{Name}; push @$gp, $og->{ADsPath}; last; } } } $gn; } sub w32umail { # E-mail address(es) of user(s) given my($s, $u) =@_[0,1]; # (self, ?user(s), ?ad fields) -> email $u =$s->user() if !$u; my $d =$s->{-smtpdomain}; join(', ' , map { my ($v, $o) =($_); !$v ? () : $v && $d && ($v =~/\@\Q$d\E/i) ? $v : ($o =eval{$s->w32user($v)}) ? (do { foreach my $f ($#_ >1 ? @_[2..$#_] : ('EmailAddress','Description')) { # !!! 'EmailAddress' not supported via WinNT:// # MSDN "IADs Property Methods"; "Using objectGUID to Bind to an Object" # LDAP://servername/ # GetObject("LDAP://") if ((eval{$o->{$f}}||'') =~/\b([\w\d_+-]+\@[\w\d.]+)\b/) { $v =$1; last } } ($v) }) : $v } split /\s*[,;]\s*/, $u) } sub ldap { # LDAP connection return($_[0]->{-c}->{-ldap}) if $_[0]->{-c}->{-ldap}; my $s =$_[0]; my $a =$s->{-ldapsrv} ||$s->{-ldap}; return (&{$s->{-die}}('LDAP connection undefined' .$s->{-ermd})) if !$a; my $r; if(ref($a) eq 'CODE') { } else { $s->logRec('ldap','Net::LDAP->new'); eval('use Net::LDAP; 1') || return (&{$s->{-die}}("use Net::LDAP -> $@" .$s->{-ermd})); $r =Net::LDAP->new(ref($a) eq 'ARRAY' ? @$a : ref($a) eq 'HASH' ? %$a : $a); return (&{$s->{-die}}("Net::LDAP->new -> $@" .$s->{-ermd})) if !$r; $a =$s->{-ldapbind}; # "user",password=>"passw", version=>3 $r->bind(ref($a) eq 'ARRAY' ? @$a : ref($a) eq 'HASH' ? %$a : !$a ? (version=>3) : $a) || return (&{$s->{-die}}("Net::LDAP->bind -> $@" .$s->{-ermd})); } $_[0]->{-c}->{-ldap} =$r; } sub ldapSearch {# LDAP search # (self, option=>value) my %a =(@_[1..$#_]); my $f =$_[0]->{-ldapsearch} && $_[0]->{-ldapsearch}->{filter} && $a{filter} ? '(&' .$a{filter} .$_[0]->{-ldapsearch}->{filter} .')' : $a{filter} ? $a{filter} : $_[0]->{-ldapsearch}->{filter} ? $_[0]->{-ldapsearch}->{filter} : ''; $_[0]->ldap; $_[0]->logRec('ldap','search',$f); my %a1=($_[0]->{-ldapsearch} ? %{$_[0]->{-ldapsearch}} : () ,%a, $f ? (filter=>$f) : ()); my $r =$_[0]->ldap->search(%a1); return (&{$_[0]->{-die}}("ldapSearch(" .join(',', map{"$_=>" .$a1{$_}} keys %a1) .') ->' .$r->error .$_[0]->{-ermd})) if $r->code; $r } sub ldapEntry { # LDAP search and return entry # (entry name) -> entry my $r =$_[0]->ldapSearch($#_ <2 ? ('filter'=> $_[1] !~/[=]/ ? $_[0]->{-ldapattr}->[0] .'=' .utf8enc($_[0],$_[1]) : $_[1]) : @_[1..$#_]); return (&{$_[0]->{-die}}('ldapRead('. join(', ',@_[1..$#_]) .'-> sevaral entries found' .$_[0]->{-ermd})) if $r->count >1; $r->entry(0); } sub ldapVal { # LDAP entry get value and decode it # (entry, attr name) -> value my $v =ref($_[1]) ? $_[1]->get_value($_[2..$#_]) : $_[0]->ldapEntry($_[1])->get_value($_[2..$#_]); !defined($v) ? ($v) : ref($v) eq 'ARRAY' ? [map {utf8dec($_[0], $_)} @$v] : utf8dec($_[0], $v) } sub ldapLst { # LDAP list # may be useful instead of 'ugf_ldap' # self, '-ug<>', ?user|group|filter, ?container, ?fields my($s,$o,$f,$r,$a) =@_; $o ='-ug' if !$o; $r =[] if !$r; $a =$s->{-ldapattr} if !$a; my $fq =($f =~/[=]/ ? $f : ($o =~/ug/) || ($o!~/[ug]/) ? ($s->{-ldapfu} && $s->{-ldapfg} ? '(|' .$s->{-ldapfu} .$s->{-ldapfg} .')' : '') : $o =~/u/ ? $s->{-ldapfu} ||'(objectClass=organizationalPerson)' : $o =~/g/ ? $s->{-ldapfg} ||'(objectClass=groupOfNames)' : ''); my $fc=ref($f) eq 'CODE' ? $f : undef; my $fm=ref($f) ? undef : $f =~/[=]/ ? undef : $f && $o !~/u/ ? $s->ugroups($f) : $f; $fq =$fq ? ('&(member=' .utf8enc($s,$fm) .")$fq") : ('(member=' .utf8enc($s,$fm) .')') if $fm && !ref($fm); my $q =$s->ldapSearch($fq ? ('filter'=>$fq) : ()); $s->logRec('ldap','list'); if (ref($r) eq 'ARRAY') { for(my $i =0; $i < $q->count; $i++) { my $v =utf8dec($s, $q->entry($i)->get_value($a->[0])||''); next if ref($fm) && !grep /^\Q$v\E$/i, @$fm; push @$r, $v } } else { for(my $i =0; $i < $q->count; $i++) { my $v =utf8dec($s, $q->entry($i)->get_value($a->[0]) ||''); my $v1=utf8dec($s, $q->entry($i)->get_value($a->[1] ||$a->[0]) ||''); next if ref($fm) && !grep /^\Q$v\E$/i, @$fm; $r->{$v} =($v1 ||$v) .($o=~/[<>]/ ? ' <' .($v ||$v1) .'>' : ''); } } $r } sub ldapUgroups { # LDAP user groups # replaced with 'ugf_ldap' # (user) -> groups my($s,$u,$g) =@_; my $n =ref($u) ? $u->get_value('dn') : $s->ldapEntry($u)->get_value('dn'); my $q =$s->ldapSearch("member=$n"); $g =[] if !$g; for(my $i =0; $i < $q->count; $i++) { push @$g, utf8dec($s, $q->entry($i)->get_value($s->{-ldapattr}->[0])||''); ldapUgroups($s, $q->entry($i), $g); } $g } ######################################################### # Database methods ######################################################### sub mdeTable { # Table MetaData Element # (self, table name) -> table metadata # Cached return ($_[0]->{-table}->{$_[1]}) if $_[0]->{-table}->{$_[1]} && $_[0]->{-table}->{$_[1]}->{'.mdeTable'}; my ($s, $tn) =@_; # Generate table # table factory may be developed &{$s->{-mdeTable}}($s, $tn) if $s->{-mdeTable} && !$s->{-table}->{$tn}; return (&{$s->{-die}}('mdeTable(' .$tn .') -> not described table' .$s->{-ermd})) if !$s->{-table}->{$tn}; # Organize table metadata $s->logRec('mdeTable', $tn); my $tm =$s->{-table}->{$tn}; $tm->{'.mdeTable'} =1; # flag of organized $tm->{-mdefld} ={}; # hash of fields if (ref($tm->{-field}) eq 'ARRAY') { foreach my $f (@{$tm->{-field}}) { # field flags setup next if !ref($f) ||ref($f) ne 'HASH'; $tm->{-mdefld}->{$f->{-fld}} =$f if $f->{-fld}; $f->{-flg} ='a' # 'a'll if !exists($f->{-flg}); if ($f->{-flg} =~/k/) { if (!$tm->{-key}) { # 'k'ey $tm->{-key} =[$f->{-fld}] } elsif (!grep {$_ eq $f->{-fld}} @{$tm->{-key}}) { push @{$tm->{-key}}, $f->{-fld} } } if ($f->{-flg} =~/w/) { # 'w'here if (!$tm->{-wkey}) { $tm->{-wkey} =[$f->{-fld}] } elsif (!grep {$_ eq $f->{-fld}} @{$tm->{-wkey}}) { push @{$tm->{-wkey}}, $f->{-fld} } } $f->{-flg} ='w' .$f->{-flg} # 'w'here if $f->{-flg} !~/w/ && $tm->{-wkey} && grep {$_ eq $f->{-fld}} @{$tm->{-wkey}}; $f->{-flg} ='k' .$f->{-flg} # 'k'ey if $f->{-flg} !~/k/ && $tm->{-key} && grep {$_ eq $f->{-fld}} @{$tm->{-key}}; $f->{-flg}.='e' # 'e'dit if $f->{-flg} !~/e/ && $f->{-edit}; } } $tm } sub mdlTable { # Tables List sort( $_[0]->{-mdlTable} ?(keys %{$_[0]->{-table}} , grep {!$_[0]->{-table}->{$_}} &{$_[0]->{-mdlTable}}) : keys %{$_[0]->{-table}}) } sub mdeQuote { # Quote field value if needed # self, table, field, value my $t =ref($_[1]) eq 'HASH' ? $_[1] : mdeTable($_[0], !ref($_[1]) ? $_[1] : ref($_[1]->[0]) ? $_[1]->[0]->[0] : $_[1]->[0]); !ref($t) || !$t->{-mdefld} || !$t->{-mdefld}->{$_[2]} || !$t->{-mdefld}->{$_[2]}->{-flg} ? ( !defined($_[3]) ? 'NULL' : ($_[3] =~/\d+/) && ($_[3] =~/^[+-]{0,1}[\d]+(?:\.[\d]+){0,1}$/) ## ($_[3] =~/^[+-]{0,1}[\d ,]+(?:.[\d ,]+){0,1}$/) ? $_[3] : !$_[0]->{-dbi} ? strquot($_[0], $_[3]) : $_[0]->{-dbi}->quote($_[3]) ) : $t->{-mdefld}->{$_[2]}->{-flg} =~/["']/ ? (!$_[0]->{-dbi} ? strquot($_[0], $_[3]) : $_[0]->{-dbi}->quote($_[3])) : $t->{-mdefld}->{$_[2]}->{-flg} =~/[9n]/ ? $_[3] : !defined($_[3]) ? 'NULL' : ($_[3] =~/\d/) && ($_[3] =~/^[+-]{0,1}[\d]+(?:\.[\d]+){0,1}$/) ## ($_[3] =~/^[+-]{0,1}[\d ,]+(?:.[\d ,]+){0,1}$/) ? $_[3] : !$_[0]->{-dbi} ? strquot($_[0], $_[3]) : $_[0]->{-dbi}->quote($_[3]) } sub mdeSubj { # Subject generalized of record # (self, data) | (self, meta, data) -> subject if ($#_ >1) { } ( ref($_[0]->{-tn}->{-ridSubject}) eq 'CODE' ? &{$_[0]->{-tn}->{-ridSubject}}(@_) : join(' ', map { !defined($_[1]->{$_}) || ($_[1]->{$_} eq '') ? () : ($_[1]->{$_}) } @{$_[0]->{-tn}->{-ridSubject}})) ||'' } sub mdeReaders {# Table readers fields # self, table my $r =!$_[0]->{-rac} || $_[0]->uadmrdr() ? undef : ref($_[1]) ? [@{$_[1]->{-racReader} ||$_[0]->{-racReader} ||[]} ,@{$_[1]->{-racWriter} ||$_[0]->{-racWriter} ||[]}] : [@{$_[0]->{-table}->{$_[1]}->{-racReader} ||$_[0]->{-racReader}||[]} ,@{$_[0]->{-table}->{$_[1]}->{-racWriter} ||$_[0]->{-racWriter}||[]}]; #$_[0]->logRec('mdeReaders',@_[1..$#_],$r); ref($r) && @$r ? $r : undef } sub mdeWriters {# Table writers fields # self, table !$_[0]->{-rac} || $_[0]->uadmwtr() ? undef : ref($_[1]) ? $_[1]->{-racWriter} ||$_[0]->{-racWriter} ||undef : $_[0]->{-table}->{$_[1]}->{-racWriter} ||$_[0]->{-racWriter} ||undef } sub mdeRAC { # Table record access control condition # self, table/form, ? option switch if ($_[2]) { my $m =ref($_[1]) ? $_[1] : ($_[0]->{-form}->{$_[1]} ||$_[0]->{-table}->{$_[1]} ||{}); return(undef) if exists($m->{$_[2]}) && !$m->{$_[2]}; } my $m =(ref($_[1]) ? ($_[1]->{-table} ? $_[0]->{-table}->{$_[1]->{-table}} : $_[1]) : $_[0]->{-form}->{$_[1]} ? ($_[0]->{-form}->{$_[1]}->{-table} ? $_[0]->{-table}->{$_[0]->{-form}->{$_[1]}->{-table}} : $_[0]->{-form}->{$_[1]}) : $_[0]->{-table}->{$_[1]} ) ||{}; ( $m->{-racActor} ||$_[0]->{-racActor} ||$m->{-racManager} ||$_[0]->{-racManager} ||$m->{-racPrincipal} ||$_[0]->{-racPrincipal} ||$m->{-racUser} ||$_[0]->{-racUser} ||$m->{-racWriter} ||$_[0]->{-racWriter} ||$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ) && $m } sub mdeRole { # Table user role fields list # self, table, role, ? altrole my $m =ref($_[1]) ? $_[1] : $_[0]->{-table}->{$_[1]}; my $r =$_[2] eq 'all' ? undef : $_[2] eq 'creator' ? [$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||()] : $_[2] eq 'updater' ? [$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ||()] : $_[2] eq 'author' ? [$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||() ,$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ||()] : $_[2] eq 'authors' ? $m->{-racWriter} ||$_[0]->{-racWriter} || mdeRole($_[0], $m, $_[3] ||'author') : $_[2] eq 'actor' ? $m->{-racActor} &&[$m->{-racActor}->[0]] || $_[0]->{-racActor} &&[$_[0]->{-racActor}->[0]] ||mdeRole($_[0], $m, $_[3] ||'actors') : $_[2] eq 'actors' ? $m->{-racActor} ||$_[0]->{-racActor} || ($_[3] ? mdeRole($_[0], $m, $_[3]) : undef) || ($m->{-rvcUpdBy} && [$m->{-rvcUpdBy}]) || ($_[0]->{-rvcUpdBy} && [$_[0]->{-rvcUpdBy}]) || mdeRole($_[0], $m, 'authors') : $_[2] eq 'manager' ? $m->{-racManager} &&[$m->{-racManager}->[0]] || $_[0]->{-racManager} &&[$_[0]->{-racManager}->[0]] ||mdeRole($_[0], $m, $_[3] ||'managers') : $_[2] eq 'managers' ? $m->{-racManager} ||$_[0]->{-racManager} || ($_[3] ? mdeRole($_[0], $m, $_[3]) : undef) || ($m->{-rvcInsBy} && [$m->{-rvcInsBy}]) || ($_[0]->{-rvcInsBy} && [$_[0]->{-rvcInsBy}]) || mdeRole($_[0], $m, 'author') : $_[2] eq 'principal' ? $m->{-racPrincipal} &&[$m->{-racPrincipal}->[0]] || $_[0]->{-racPrincipal} &&[$_[0]->{-racPrincipal}->[0]] || mdeRole($_[0], $m, $_[3] ||'principals') : $_[2] eq 'principals' ? $m->{-racPrincipal} ||$_[0]->{-racPrincipal} || ($_[3] ? mdeRole($_[0], $m, $_[3]) : undef) || ($m->{-rvcInsBy} && [$m->{-rvcInsBy}]) || ($_[0]->{-rvcInsBy} && [$_[0]->{-rvcInsBy}]) || mdeRole($_[0], $m, 'author') : $_[2] eq 'user' ? $m->{-racUser} &&[$m->{-racUser}->[0]] || $_[0]->{-racUser} &&[$_[0]->{-racUser}->[0]] || mdeRole($_[0], $m, $_[3] ||'users') : $_[2] eq 'users' ? $m->{-racUser} ||$_[0]->{-racUser} || mdeRole($_[0], $m, $_[3] ||'principals') : mdeRole($_[0], $m, 'authors'); ref($r) && @$r ? $r : undef } sub mdeRoles { # Table user roles list # self, table/form ||0, ? pass value return(qw(all author authors actor actors manager managers principal principals user users)) if !$_[1]; my $m =!$_[1] ? $_[1] : (mdeRAC(@_) ||{}); my $v; my @l =('all' #,!$m ||$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ? ('creator') : () #,!$m ||$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ? ('updater') : () ,!$m ||$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} || !$m ||$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ? ('author') : () ,!$m ||$m->{-racWriter} ||$_[0]->{-racWriter} ? ('authors') : () ,(!($v =!$m ||$m->{-racActor}||$_[0]->{-racActor}) ? () : $#$v >0 ? (qw(actor actors)) : qw(actor)) ,(!($v =!$m ||$m->{-racManager}||$_[0]->{-racManager}) ? () : $#$v >0 ? (qw(manager managers)) : qw(manager)) ,(!($v =!$m ||$m->{-racPrincipal}||$_[0]->{-racPrincipal}) ? () : $#$v >0 ? (qw(principal principals)) : qw(principal)) ,(!($v =!$m ||$m->{-racUser}||$_[0]->{-racUser}) ? () : $#$v >0 ? (qw(user users)) : qw(user)) ); push @l, $_[2] if $_[2] && !grep {$_ eq $_[2]} @l; @l } sub mdeFldIU { # Field of Inserters/Updaters $_[2] # self, table meta, field &&(($_[1]->{-rvcInsBy} && ($_[1]->{-rvcInsBy} eq $_[2])) || ($_[0]->{-rvcInsBy} && ($_[0]->{-rvcInsBy} eq $_[2])) || ($_[1]->{-rvcUpdBy} && ($_[1]->{-rvcUpdBy} eq $_[2])) || ($_[0]->{-rvcUpdBy} && ($_[0]->{-rvcUpdBy} eq $_[2]))) } sub mdeFldRW { # Field of Readers/Writers # self, table meta, field return(undef) if !$_[2] || !($_[1]->{-racReader} ||$_[0]->{-racReader} ||$_[1]->{-racWriter} ||$_[0]->{-racWriter}); foreach my $e ( $_[1]->{-racReader} ? @{$_[1]->{-racReader}} : $_[0]->{-racReader} ? @{$_[0]->{-racReader}} : () , $_[1]->{-racWriter} ? @{$_[1]->{-racWriter}} : $_[0]->{-racWriter} ? @{$_[0]->{-racWriter}} : ()) { return($_[2]) if $e eq $_[2] } return(undef) } sub mddUrole { # Display UROLE my ($s, $m, $n) =@_; # self, meta, role $m =$s->mdeTable($m->{-table}) if $m->{-table}; my $l =$s->mdeRole($m, $n); join(', ' , $l ? (map {$_ && $m && $m->{-mdefld} && $m->{-mdefld}->{$_} # && ($s->lngslot($m->{-mdefld}->{$_},'-lbl') || $s->lng(0,$_)) && $s->lnglbl($m->{-mdefld}->{$_},'-fld') || $_ } @$l) : () , $n =~/^(?:manager|principal|user)$/i ? '! ' .$s->mddUrole($m, 'actor') : $n =~/^(?:managers|principals|users)$/i ? '! ' .$s->mddUrole($m, 'actors') : () ) || $n } sub recType { # Record type or table name $_[1]->{-table} || ($_[1]->{-form} && $_[0]->{-form}->{$_[1]->{-form}} && $_[0]->{-form}->{$_[1]->{-form}}->{-table}) || (ref($_[2]) ne 'HASH' && substr($_[2], 0, index($_[2],'='))) # class name } sub recFields { # Field names in the record hash # !!! sort degradation, needed to use 'recValues' sort grep {substr($_,0,1) ne '-' && substr($_,0,1) ne '.'} keys %{$_[1]} } sub recValues { # Field values in the record hash map {$_[1]->{$_}} recFields($_[0], $_[1]) } sub recData { # Field name => value hash ref return({map {($_=> $_[1]->{$_})} recFields($_[0], $_[1])}) } sub recKey { # Record's key: field => value hash ref # self, table name, record my $m =$_[0]->{-table}->{$_[1]} ||$_[0]->{-form}->{$_[1]}; $m && $m->{-key} ? {map {($_=>$_[2]->{$_})} @{$m->{-key}}} : $_[2]->{'id'} # 'id' field present ? {'id'=>$_[2]->{'id'}} : {} } sub recWKey { # Record's optimistic key: field => value hash ref # self, table name, record my $m =$_[0]->{-form}->{$_[1]} ||$_[0]->{-table}->{$_[1]}; return(recKey(@_)) if !$m; my $r ={}; if ($m->{-wkey}) { $r ={map {($_=>$_[2]->{$_}) } grep {defined($_[2]->{$_}) } @{$m->{-wkey}}} } %$r ? $r : recKey(@_) } sub rmlClause { # Command clause words and values list from record's hash ref # (record manipulation language) # !!! sort degradation, for nice display map {($_=>$_[1]->{$_})} sort grep {substr($_,0,1) eq '-'} keys %{$_[1]} } sub rmlKey { # Record's '-key' clause value # ($self, {command}, {data}) $_[1]->{-key} && !ref($_[1]->{-key}) # should be translated ? {'id'=>rmlIdSplit(@_[0,1],$_[1]->{-key})} : $_[1]->{-key} # already exists ? $_[1]->{-key} : $_[1]->{-where} # not needed using '-where' ? $_[1]->{-key} : $_[1]->{-table} # key described && $_[0]->{-table}->{$_[1]->{-table}}->{-key} ? {(map {($_=>$_[2]->{$_})} @{$_[0]->{-table}{$_[1]->{-table}}->{-key}})} : $_[2]->{'id'} # 'id' field present ? {'id'=>rmlIdSplit(@_[0,1],$_[2]->{'id'})} : undef } sub rmlIdSplit {# Split record ID into table name and real ID # ($self, {command}, key value) !$_[0]->{-idsplit} ? $_[2] : ref($_[0]->{-idsplit}) ? &{$_[0]->{-idsplit}}(@_) : $_[2] =~m/([^\Q$RISM0\E]+)\Q$RISM1\E((?:.(?!\Q$RISM1\E))+)$/ # !!! optimize: 'database $RISM0 table $RISM1 rowid' ? eval{$_[1]->{-table}=$1; $2} # 'table//rowid', table !~m!/!, rowid !~m!//! : $_[2] } sub rmiTrigger {# Execute trigger # (record manipulation internal) # self, {command}, {data}, {record}, trigger names my $tbl =$_[1]->{-table} && $_[0]->{-table}->{$_[1]->{-table}}; my $frm =$_[1]->{-form} && $_[0]->{-form} && $_[0]->{-form}->{$_[1]->{-form}}; local $_[1]->{-cmdt} =$tbl || $frm; # table metadata local $_[1]->{-cmdf} =$frm || $tbl; # form metadata local $_[0]->{-affect} =undef; local $_[0]->{-rac} =undef; foreach my $t (@_[4..$#_]) { $_[0]->logRec('rmiTrigger' , (caller(1))[3] =~/([^:]+)$/ ? $1 : (caller(1))[3] , -cmd=>$_[1]->{-cmd} || 'undef' , $tbl && $_[1]->{-table} ? (-table=>$_[1]->{-table}) : () , $frm && $_[1]->{-form} ? (-form=>$_[1]->{-form}) : () , $_[1]->{-key} ? (-key=>$_[1]->{-key}) : () # , $_[2] ? (-data=>$_[2]) : () , join(' ',@_[4..$#_]) ) if 0; &{$_[0]->{$t}}($_[0], $_[1], $_[2], $_[3]) if $_[0]->{$t} && !($t eq '-recInsID' && $tbl && $tbl->{$t}); &{$tbl->{$t}} ($_[0], $_[1], $_[2], $_[3]) if $tbl && $tbl->{$t}; &{$frm->{$t}} ($_[0], $_[1], $_[2], $_[3]) if $frm && $frm->{$t} && ($frm->{$t} ne $tbl->{$t}); } $_[0] } sub rmiIndex { # Index record # {-table=>name}, {newData=>value}, {oldData=>value} my ($s, $a, $d, $r) =@_; my $n =$d; # {%$r} ||{}; @{$n}{keys %$d} =values %$d; my @q =([undef,'-'],[undef,'+']); local $s->{-affect} =undef; local $s->{-rac} =undef; if (my $m =$s->{-table}->{$a->{-table}}->{-recIndex0R}) { &$m($s, $a, $d, $r) } foreach my $x (keys %{$s->{-table}}) { next if !ref($s->{-table}->{$x}->{-ixcnd}); my $i =$s->{-table}->{$x}; $q[0]->[0] =$r && &{$i->{-ixcnd}}($s, $a, $r) ? $r : 0; # delete $q[1]->[0] =$d && &{$i->{-ixcnd}}($s, $a, $n) ? $n : 0; # insert/update foreach my $q (@q) { next if !$q->[0]; my $v = $i->{-ixrec} ? &{$i->{-ixrec}}($s, $a, $q->[0], $q->[1]) : $i->{-field} && ref($i->{-field}) eq 'ARRAY' ? {map {$q->[0]->{$_}} grep {ref($_) && $_->{-fld}} @{$i->{-field}}} : $i->{-field} && ref($i->{-field}) eq 'HASH' ? {map {$q->[0]->{$_}} keys %{$i->{-field}}} : undef; foreach my $r (!ref($v) ? () : ref($v) eq 'ARRAY' ? @$v : ($v)) { my $k =rmlKey($s, {-table=>$x}, $r); $q->[1] eq '-' ? $s->dbiDel({-table=>$x, -key=>$k}, $r) : 1 && eval{$s->dbiIns({-table=>$x, -key=>$k}, $r)} ? 0 # !!! dbiIns better, dbiUpd safer : $s->dbiUpd({-table=>$x, -key=>$k, -save=>1}, $r, $d); } } } $d } sub recIndex { # Update/delete index entry, for calls from '-recIndex0R' # index name, {key}, {data}||undef !$_[0]->{-table}->{$_[1]}->{-ixcnd} ? &{$_[0]->{-die}}('recIndex(' .$_[1] .') -> not described index' .$_[0]->{-ermd}) : $_[3] ? $_[0]->dbiUpd({-table=>$_[1], -key=>$_[2], -save=>1}, $_[$#_]) : $_[0]->dbiDel({-table=>$_[1], -key=>$_[2]}); } sub recReindex{ # Reindex database # self, clear, indexes my ($s, $c, @i) =@_; $s->varLock(); my @t =grep {!$s->{-table}->{$_}->{-ixcnd}} $s->mdlTable(); @i =grep { $s->{-table}->{$_}->{-ixcnd}} keys %{$s->{-table}} if !@i; if ($c) { foreach my $i (@i) { $s->dbiTrunc($i); } } foreach my $t (@t) { $s->logRec('recReindex', $t); my $a ={-table=>$t,-version=>1}; my $c =$s->recSel(%$a); my $r; while ($r =$c->fetchrow_hashref()) { $s->logRec('recReindex',$r); $s->rmiIndex($a, $r) } } $s } sub rfdName { # Record's files directory name # self, command |table name, record data, subdirectory,... my $t =ref($_[1]) ? $_[1]->{-table} : $_[1]; my $m =$_[0]->{-table}->{$t}; join('/' , $_[0]->{-cgibus} ? ($t ,$_[2]->{$m->{-rvcActPtr} ||$_[0]->{-rvcActPtr} ||'-none'} ? 'ver' : 'act') : ($_[2]->{$m->{-rvcActPtr} ||$_[0]->{-rvcActPtr} ||'-none'} ? 'v' : 'a' ,$t) , &{$m->{-rfdName} ||$_[0]->{-rfdName} ||sub{ my $r =''; foreach my $e (@_[1..$#_]) { for (my $i =0; $i <=length($e); $i +=3) { my $v =substr($e, $i, 3); # $v =~s/([,;+:'"?*%\/\\])/uc sprintf("%%%02x",ord($1))/eg; $v =~s/([^a-z0-9_-])/uc sprintf("%%%02x",ord($1))/eg; $r .=$v .'/' } } chop($r); $r }}( $_[0] , map { defined($_[2]->{$_}) ? $_[2]->{$_} : $_[1]->{-key}->{$_} } @{$m->{-key}}) . $RISM2 , map { my $v =$_; $v =~s/([,;+:'"?*%])/uc sprintf("%%%02x",ord($1))/eg; $v} @_[3..$#_] # encoding as 'rfaUpload' ) } sub rfdPath { # Record's files directory path # self, -path|-url|-urf, rfdName |{data} |({command}|table, {data}), ?subdirectory... return(undef) if !$_[0]->{$_[1]}; join('/' , $_[0]->{-cgibus} ? ($_[1] eq '-path' ? $_[0]->{-cgibus} : $_[1] ne '-urf' ? $_[0]->{$_[1]} : !$_[0]->{$_[1]} # !!! lost code, for example ? (($ENV{REMOTE_ADDR}||'') ne '127.0.0.1' ? $_[0]->{-url} : $_[0]->{-path}) : $_[0]->{$_[1]}) : $_[1] ne '-urf' ? $_[0]->{$_[1]} .'/rfa' # -url, -path : !$_[0]->{$_[1]} # !!! lost code, for example ? (($ENV{REMOTE_ADDR}||'') ne '127.0.0.1' ? $_[0]->{-url} : $_[0]->{-path}) .'/rfa' : ($_[0]->{-urf} eq $_[0]->{-url}) || (substr($_[0]->{-urf},7) eq $_[0]->{-path}) ? $_[0]->{-urf} .'/rfa' : $_[0]->{-urf} , !ref($_[3]) # rfdName, !ref($_[2]) && !ref($_[3]) ? ((ref($_[2]) ? $_[2]->{-file} || return(&{$_[0]->{-die}}('rfdPath(' .$_[0]->strdata(@_) .') -> no file attachments' .$_[0]->{-ermd})||'') : $_[2]) ,map {my $v =$_; $v =~s/([,;+:'"?*%])/uc sprintf("%%%02x",ord($1))/eg; $v} @_[3..$#_]) # encoding as 'rfdName' and 'rfaUpload' : rfdName($_[0],@_[2..$#_])) } sub rfdEdmd { # Record's files directory editing allowed? # self, command |table name, record data my $m =$_[0]->{-table}->{ ref($_[1]) ? ($_[1]->{-table} || $_[1]->{-form} && $_[0]->{-form}->{$_[1]->{-form}}->{-table}) : ($_[0]->{-table}->{$_[1]} && $_[1] ||$_[0]->{-form}->{$_[1]}->{-table}) }; my $u =$m->{-rvcChgState} ||$_[0]->{-rvcChgState}; my $v =$m->{-rvcActPtr} ||$_[0]->{-rvcActPtr}; my $r =$_[2]; !$v || ($u && ($r->{$u->[0]} && grep {$r->{$u->[0]} eq $_} @{$u}[1..$#{@$u}])) } sub rfdTime { # mtime of record files directory # self, (command |table name, record data) |rfdName (stat(rfdPath($_[0], -path=>$_[2] ? rfdName(@_[0..2]) : $_[1])))[9]; } sub rfdStamp { # Stamp record with files directory name, create if needed # self, command |table name, record data, acl set my $d =rfdName(@_[0..2]); my $p =rfdPath($_[0],-path=>$d); my $e =rfdEdmd(@_[0..2]); my $r =$_[2]; my $w =$_[3]; if ($e && !-d $p) { $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; $_[0]->pthMk($p); } if (-d $p) { $r->{-file} =$d; $r->{-fupd} =$d if $e} else { delete $r->{-file}; delete $r->{-fupd}} if ($r->{-file} && $w) { # set ACL $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; my $s =$_[0]; my $m =$s->{-table}->{ref($_[1]) ? $_[1]->{-table} : $_[1]}; my $wr=$m->{-racReader} ||$s->{-racReader}; $wr=[map {defined($r->{$_}) ? (split /\s*[,;]\s*/i, $r->{$_}) : ()} @$wr] if $wr; my $ww=$m->{-racWriter} ||$s->{-racWriter}; $ww=[map {defined($r->{$_}) ? (split /\s*[,;]\s*/i, $r->{$_}) : ()} @$ww] if $ww; if ($wr ||$ww) { my $ld=$^O eq 'MSWin32' && $s->w32domain() || ''; my @wa= map {$_ =~s/ /_/g; $_} map {$_ =~/^([^\\@]+)([\\@])([^\\@]+)$/ ? ($_, $3 .($2 eq '@' ? '\\' : '@') .$1) : $ld ? ($_, $ld .'\\' .$_, $_ .'@' .$ld) : $_} (map {!$_ ? () : ref($_) ? @$_ : ($_) } $s->{-fswtr}, $s->{-fsrdr}, $ww, $wr); # ||getlogin() my $wf=$s->hfNew('+>',"$p/.htaccess"); $wf->store('', "\n" ,"require user\t" .join(' ',@wa), "\n" ,"require group\t" .join(' ',@wa), "\n" ,'',"\n"); $wf->close(); } if (($wr ||$ww) && $^O eq 'MSWin32' && Win32::IsWinNT()) { # $ENV{OS} && $ENV{OS}=~/Windows_NT/i # !!! WMI may be better/faster for all filesystem security # MSDN: WMI Security Descriptor Objects # Win32_LogicalFileSecuritySetting # Win32_LogicalFileSecuritySetting.GetSecurityDescriptor # Win32_LogicalFileSecuritySetting.SetSecurityDescriptor # Win32_SecurityDescriptor # Win32_ACE # how to create? # Win32_Trustee # how to create? # $wmiobj=Win32::OLE->GetObject("winmgmts:Win32_LogicalFileSecuritySetting.path='$obj'") # $out=$wmiobj->ExecMethod_("GetSecurityDescriptor"); # die if !$out ||$out->{ReturnValue}; # $out->{Descriptor}->{Owner}->{Domain} # .'\\' .$out->{Descriptor}->{Owner}->{Name}; # $dacl=$out->{Descriptor}->{DACL}; # die if !$dacl; # foreach my $k (@$dacl) { # $k->{Trustee}->{Domain} # $k->{Trustee}->{Name} # $k->{AceType} # 0 ADS_ACETYPE_ACCESS_ALLOWED # =| $k->{AccessMask} # 1 ADS_ACETYPE_ACCESS_DENIED # =& $k->{AccessMask} # %permf=('FULL'=>2032127,'CHANGE'=>1245631,'ADD&READ&EXECUTE'=>1180095,'ADD&READ'=>1180063,'READ&EXECUTE'=>1179817,'READ'=>1179785,'ADD'=>1048854); # %permd=('FULL'=>2032127,'CHANGE'=>1245631,'ADD&READ'=>1180095,'READ'=>1179817,'LIST'=>1179785,'ADD'=>1048854); # $k->{AccessMask} >=$perm{$k->{AccessMask}} # xcacls.vbs # objLocator.ConnectServer.Get("Win32_SecurityDescriptor").Spawninstance_ # $p =~s/\//\\/g; if (1 || $s->{-c}->{-RevertToSelf}) { # ownership $s->logRec('TakeOwnerShip', 'winmgmts:Win32_Directory.Name', $r->{-file}); eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0);'); my $ow =Win32::OLE->GetObject("winmgmts:Win32_Directory.Name='$p'"); $s->logRec("Error Win32::OLE::GetObject() -> " .Win32::OLE->LastError()) if !$ow; $ow =$ow && $ow->TakeOwnerShip(); $s->logRec("Error TakeOwnerShip() -> $ow") if $ow; } # access control $s->osCmd('cacls', "\"$p\"", '/T','/C','/G' ,(map { $_ =~/\s/ ? "\"$_\"" : $_ } map{(m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_) .':F' } ref($s->{-fswtr}) ? (@{$s->{-fswtr}}) : ($s->{-fswtr} ||eval{Win32::LoginName})) ,$s->{-fsrdr} ?(map { $_ =~/\s/ ? "\"$_\"" : $_ } map{(m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_) .':R' } ref($s->{-fsrdr}) ? (@{$s->{-fsrdr}}) : ($s->{-fsrdr})) :() ,sub{CORE::print "Y\n"}); if ($e && $ww) { foreach my $u (map {m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_} @$ww) { $s->osCmd('-i','cacls', "\"$p\"" , '/E','/T','/C','/G' , ($u =~/\s/ ? "\"$u\"" : $u) .':F') } foreach my $u (map {m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_} $wr ? @$wr : ()) { $s->osCmd('-i','cacls', "\"$p\"" , '/E','/T','/C','/G' , ($u =~/\s/ ? "\"$u\"" : $u) .':R') } } else { foreach my $u (map {m/([^@]+)\@([^@]+)/ ? "$2\\$1" : $_ } map {$_ ? @$_ : ()} $ww, $wr) { $s->osCmd('-i','cacls', "\"$p\"" , '/E','/T','/C','/G' , ($u =~/\s/ ? "\"$u\"" : $u) .':R') } } } if ($w && ($w =~/^\d+$/)) { my $wa =(stat($p))[8]; $s->logRec('utime', $s->strtime($wa||$w), $s->strtime($w), $r->{-file}); utime($wa ||$w, $w, $p); } } $r->{-file} } sub rfdCp { # Copy record's files directory to another record # self, source {record} |rfdName, dest {command} |table, {record} $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; my $fd =ref($_[1]) ? $_[1]->{-file} : $_[1]; return(0) if !$fd; my $fp =rfdPath($_[0],-path=>$fd); return(0) if ! -d $fp; my $td =rfdName($_[0], @_[2..$#_]); my $tp =rfdPath($_[0],-path=>$td); $_[0]->pthMk($tp) && $_[0]->pthCp('-r',$fp,$tp) && ($_[3]->{-file} =$td); } sub rfdRm { # Remove record's files directory # self, rfdName |{record} |({command} |table, {record}) $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; my $p =rfdPath($_[0], -path=>ref($_[1]) && $_[1]->{-file} ? $_[1]->{-file} : @_[1..max($_[0], 2, $#_)]); $p =-d $p ? $_[0]->pthRm('-r', $p) && $_[0]->pthCln($p) : $p; delete $_[1]->{-file} if $p && ref($_[1]); $p } sub rfdCln { # Clean record's files directory, delete if empty # self, rfdName |{record} |({command} |table, {record}) $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; my $p =rfdPath($_[0], -path=>ref($_[1]) && $_[1]->{-file} ? $_[1]->{-file} : @_[1..max($_[0], 2, $#_)]); $p =$_[0]->pthCln($p); delete $_[1]->{-file} if $p && ref($_[1]) && !-d $p; $p } sub rfdGlobn { # Glob record's files directory, return attachments names # self, rfdName |{record} |({command} |table, {record}), subdirectory... $_[0]->pthGlobn($_[0]->rfdPath(-path=>@_[1..$#_]) .'/*') } sub rfaRm { # Delete named attachment(s) in record's files directory # self, rfdName |{record} |({command} |table, {record}), attachment|[attachments] $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; grep {$_[0]->pthRm('-r',$_[0]->rfdPath(-path=>@_[1..$#_-1], $_)) } ref($_[$#_]) ? @{$_[$#_]} : $_[$#_] } sub rfaUpload { # Upload named attachment into record's files directory # self, rfdName |{record} |({command} |table, {record}), cgi file $_[0]->w32IISdpsn() if $_[0]->{-w32IISdpsn} && !$_[0]->{-c}->{-RevertToSelf}; my $fn =$_[0]->cgi->param($_[$#_]); $fn =$fn =~/[\\\/]([^\\\/]+)$/ ? $1 : $fn; $fn =~s/([,;+:'"?*%])/uc sprintf("%%%02x",ord($1))/eg; my $fh =$_[0]->cgi->upload($_[$#_]) ||return(&{$_[0]->{-die}}($_[0]->lng(0,'rfaUpload') ."('" .$_[$#_] ."') CGI::upload -> " .$_[0]->lng(1,'rfaUplEmpty') ."\n")); binmode($fh); eval('use File::Copy'); File::Copy::copy($fh, $_[0]->rfdPath(-path=>@_[1..$#_-1], $fn)) || &{$_[0]->{-die}}($_[0]->lng(0,'rfaUpload') ."('" .$_[$#_] ."'): File::Copy::copy -> $!\n"); eval{close($fh)}; } sub recActor { # User's role ('admin','owner','-...', field); cached using -editable # (table|command, record, ?db record , role | field | 0,...) -> boolean return(1) if $_[0]->uadmin(); return(recActor($_[0],$_[1],$_[3]||$_[2],@_[4..$#_])) if ref($_[3]) ||(!$_[3] && ($#_ >3)); return(undef) if !$_[3] || !ref($_[2]); return($_[2]->{-editable}) if exists($_[2]->{-editable}) && (!$_[2]->{-editable} || !$_[3]); return(scalar(grep {recActor($_[0],$_[1],$_[2],$_)} @_[3..$#_])) if $#_ >3; return($_[2]->{-editable}->{$_[3]}) if ref($_[2]->{-editable}) && exists($_[2]->{-editable}->{$_[3]}); my ($s,$f,$r,$n) =@_; if (!ref($f)) {} elsif ($f->{-cmdt}) {$f =$f->{-cmdt}} elsif ($f->{-table}) {$f =$f->{-table}} if (!exists($r->{-editable})) { my $mt=ref($f) ? $f : !$f ? undef : $s->mdeTable($f); return(undef) if !$mt; my $w =mdeWriters($s, $mt); $r->{-editable} =!$w ||$s->ugmember(map {$r->{$_}} @$w); return(undef) if !$r->{-editable}; } return($_[2]->{-editable}) if !$n; $r->{-editable} ={} if !ref($r->{-editable}); if ($n =~/^(-racOwner)$/) { # 'owner' role my $n =$1; my $mt =ref($f) ? $f : !$f ? undef : $s->mdeTable($f); $r->{-editable}->{$n} =1; foreach my $k (qw(-rvcInsBy -rvcUpdBy)) { my $nf=($mt && $mt->{$k}) || ($s->{$k}) || ($s->{-tn}->{$k}); next if !$nf || !exists($r->{$nf}) || (lc($r->{$nf}) eq lc($s->user())); $r->{-editable}->{$n} =undef; last } } elsif (substr($n,0,1) eq '-') { # -racReader, -racWriter; -racActor, -racManager, -racPrincipal, -racUser my $mt =ref($f) ? $f : !$f ? undef : $s->mdeTable($f); $r->{-editable}->{$n} =$s->ugmember( map {$r->{$_} ? $r->{$_} : () } @{($mt && $mt->{$n}) || $s->{$n} ||[]}) } else { # field name $r->{-editable}->{$n} =!defined($r->{$n}) || ($r->{$n} eq '') ? undef : $s->ugmember($r->{$n}) } #$s->logRec('recActor',$n) if $r->{-editable}->{$n}; $r->{-editable}->{$n} } sub recActLim { # Bound fields my ($s, $c, $rn, $rb, $fo, @fn) =@_; # (cmd, new data, db data, opt, fld names | -recDel) my $rr =ref($rn) ? $rn : $rb; # 1-'v'iew, 2-e'x'clude return(undef) if !ref($rr); # []-restrict values; '-recRead' $s->logRec('recActLim',$c->{-cmd},$fo, @fn); if ($fo eq '-recRead') { delete $rr->{-editable}; return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,$c->{-cmd}) .": " .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef) if $c->{-cmd} && ($c->{-cmd} !~/^(?:recRead)$/); return(1) } delete $rr->{-editable} if ref($rr->{-editable}) && exists($rr->{-editable}->{-racWriter}) && !$rr->{-editable}->{-racWriter}; $s->recActor($c, $rr, 0) if !$rr->{-editable}; return(undef) if !$rr->{-editable} && !$rr->{-new}; return(!$c->{-cmdt} ? return(&{$s->{-die}}($s->lng(0,'recActLim') ." no {-cmdt}" .$s->{-ermd}) && undef) : $s->recActLim($c, $rn, $rb, $1 , (map{ my $n =(ref($_) ne 'HASH') ||!$_->{-fld} ||(exists($_->{-edit}) && (!$_->{-edit} || ref($_->{-edit}))) ||($_->{-flg} && ($_->{-flg}!~/[aeu]/)) ? '' : $_->{-fld}; !$n ? () : !(grep {$n eq $_} @_[5..$#_]) ? ($n) : () } @{$c->{-cmdt}->{-field}}))) if $fo =~/^(\w)!/; $rr->{-editable} ={} if !ref($rr->{-editable}); $rr->{-editable}->{-fr} ={} if !$rr->{-editable}->{-fr}; $fo = $fo eq 'v' ? 1 : $fo eq 'x' ? 2 : 1 if $fo && !ref($fo) && $fo =~/\w/; my $fh =$rr->{-editable}->{-fr}; # fields restrictions hash my $ds =undef; # delete restriction if ($c->{-cmd} && ($c->{-cmd} =~/^(?:recRead|recForm)$/) && !$c->{-edit} ) { $fh->{-recDel} =$ds =1 if grep /^-recDel$/, @fn; } elsif ($c->{-cmd} && ($c->{-cmd} =~/^(?:recNew|recRead|recForm|recDel)$/)) { foreach my $fn (@fn) { $fh->{$fn} =$fo; if (ref($fo) && $rn && defined($rn->{$fn}) && !grep {$rn->{$fn} eq $_} @$fo) { $rn->{$fn} =$fo->[0]; } $ds =1 if $fn eq '-recDel'; } } else { foreach my $fn (@fn) { $fh->{$fn} =$fo; $ds =1 if $fn eq '-recDel'; if (!$fo || (substr($fn,0,1) eq '-') ) { } elsif (ref($fo)) { # restricted values if (ref($rn) && (ref($fo) eq 'ARRAY')) { return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recUpd') ." ('$fn', " .join(', ', map {defined($_) ? "'$_'" : 'undef' } $rn->{$fn}, @$fo) ."): " .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef) if !defined($rn->{$fn}) || !(grep {$rn->{$fn} eq $_} @$fo); } } if (ref($rn) && ref($rb)) { if ($fo ==1) { # view only return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recUpd') ." ('$fn', " .join(', ', map {defined($_) ? "'$_'" : 'undef' } $rn->{$fn}, $rb->{$fn}) ."): " .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef) if (defined($rn->{$fn}) ? $rn->{$fn} : '') ne (defined($rb->{$fn}) ? $rb->{$fn} : ''); } elsif ($fo ==2) { # exclude delete $rn->{$fn} } } elsif (!$rb) { if ($fo ==1) { # view only } elsif ($fo ==2) { # exclude delete $rn->{$fn} } } } } if ($ds) { $ds =$c->{-cmdt} && $c->{-cmdt}->{-rvcDelState} ||$s->{-rvcDelState}; $fh->{$ds->[0]} =[grep { $_ ne $ds->[1] } ref($fh->{$ds->[0]}) ? @{$fh->{$ds->[0]}} : @{$c->{-cmdt}->{-mdefld}->{$ds->[0]}->{-inp}->{-values}} ] if $ds && (!$fh->{$ds->[0]} || (ref($fh->{$ds->[0]}) eq 'ARRAY')) && $c->{-cmdt}->{-mdefld} && $c->{-cmdt}->{-mdefld}->{$ds->[0]} && $c->{-cmdt}->{-mdefld}->{$ds->[0]}->{-inp} && (ref($c->{-cmdt}->{-mdefld}->{$ds->[0]}->{-inp}->{-values}) eq 'ARRAY'); return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recDel') .": " .$s->lng(1,'recDelAclStp') .$s->{-ermd}) && undef) if ($c->{-cmd} && ($c->{-cmd} eq 'recDel')) || ($c->{-cmd} && ($c->{-cmd} !~/^(?:recRead|recForm)$/) && $ds && $rn && $rn->{$ds->[0]} && ($rn->{$ds->[0]} eq $ds->[1])); } 1 } sub recNew { # Create new record to be inserted into database # -table=>name, field=>value || -data=>{values} # -key=>prototype record key, -proto=>{values} my $s =$_[0]; $s->logRec('recNew', @_[1..$#_]); my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]}); my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a; my $r =$d; $a->{-cmd} ='recNew'; $a->{-table}=recType ($s, $a, $d); $a->{-key} =rmlKey($s, $a, {}); my $m =mdeTable($s,$a->{-table}); foreach my $w (qw(-rvcInsBy -rvcUpdBy)) {foreach my $c ($m, $s) { next if !$c->{$w}; $r->{$c->{$w}} =$s->user; last }} foreach my $w (qw(-rvcInsWhen -rvcUpdWhen)) {foreach my $c ($m, $s) { next if !$c->{$w}; delete $r->{$c->{$w}}; last }} foreach my $w (qw(id -file -fupd)) { delete $r->{$w}; } $r->{-new} =$s->strtime(); $r->{-editable} =1 if $s->{-rac} && ($m->{-racWriter}||$s->{-racWriter}); rmiTrigger($s, $a, $r, undef, qw(-recForm0C)); my $p =$a->{-proto} || ((grep {$_} values %{$a->{-key}}) ? $s->recRead_($m, {%$a, -data=>undef, -test=>1}) : {}); rmiTrigger($s, $a, $r, $p, qw(-recNew0C)); rmiTrigger($s, $a, $r, undef, qw(-recForm0R -recFlim0R -recEdt0R -recNew0R -recNew1C -recForm1C)); $r } sub recForm { # Recalculate record - new or existing # -table=>name, field=>value || -data=>{values} # -key=>original my $s =$_[0]; # $s->logRec('recForm', @_[1..$#_]); my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]}); my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a; $a->{-cmd} ='recForm'; $a->{-table}=recType ($s, $a, $d); $a->{-key} =rmlKey($s, $a, $d); my $m =mdeTable($s,$a->{-table}); rmiTrigger($s, $a, $d, undef, qw(-recForm0C)); my $r =(!$d->{-new} && (grep {$_} values %{$a->{-key}}) && $s->recRead_($m, {%$a,-data=>undef,-test=>1})) ||undef; map {$d->{$_} =$r->{$_} if !exists($d->{$_})} keys %$r if $r; foreach my $w (qw(-rvcInsBy -rvcUpdBy)) {foreach my $c ($m, $s) { next if !$c->{$w}; $d->{$c->{$w}} =$s->user if !$d->{$c->{$w}}; last }} $d->{-editable} =1 if ($r && $r->{-editable}) || ($d->{-new} && $s->{-rac} && ($m->{-racWriter}||$s->{-racWriter})); rmiTrigger($s, $a, $d, $r, qw(-recForm0R -recFlim0R -recEdt0R -recForm1C)); $d } sub recIns { # Insert record into database # -table=>table, field=>value || -data=>{values} # -key=>{sample}, -from=>cursor my $s =$_[0]; $s->varLock if $s->{-serial} && $s->{-serial} ==2; $s->logRec('recIns', @_[1..$#_]); my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]}); my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a; $a->{-cmd} ='recIns'; $a->{-table}=recType ($s, $a, $d); $a->{-key} =rmlKey($s, $a, $d); my $m =mdeTable($s,$a->{-table}); my $v =$m->{-rvcActPtr} ||$s->{-rvcActPtr}; my $b =$m->{-rfa} ||$s->{-rfa}; my $tu=time(); foreach my $w (qw(-rvcInsBy -rvcUpdBy)) {foreach my $c ($m, $s) { next if !$c->{$w}; $d->{$c->{$w}} =$s->user; last }} foreach my $w (qw(-rvcInsWhen -rvcUpdWhen)) {foreach my $c ($m, $s) { next if !$c->{$w}; $d->{$c->{$w}} =$s->strtime($tu); last }} rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recIns0C)); my $r =undef; my $p =(grep {$_} values %{$a->{-key}}) && $s->recRead_($m,{%$a, -data=>undef, -test=>1}); if ($p) { # form record with prototype my $t =recData($s, $p); delete $t->{$v}; @{$t}{keys %$d} =values %$d; if ($a eq $d) {$a =$d =$t} else {$d =$t} } # !!! Permissions should be checked in -recIns0C trigger, no other way if ($a->{-from}) { # insert from cursor my $j =0; while (my $e =$a->{-from}->fetchrow_hashref()) { my $t ={%$e}; # readonly hash rfdStamp($s, $a, $t) if $b; @{$t}{recFields($s, $d)} =recValues($s, $d); rmiTrigger($s, $a, $t, undef, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recIns0R -recInsID -recChg0W)); rfdCp ($s, $t->{-file}, $a, $t) if !$a->{-file} && $t && $t->{-file}; rfdCp ($s, $p->{-file}, $a, $t) if !$a->{-file} && $p && $p->{-file}; rfdCp ($s, $a->{-file}, $a, $t) if $a->{-file}; rmiIndex ($s, $a, $t) if $m->{-index} ||$s->{-index}; $r =$s->dbiIns($a, $t); rfdStamp($s, $a, $r, $tu) if $t && $t->{-file} || $p && $p->{-file}; rmiTrigger($s, $a, $r, undef, qw(-recIns1R)) if $r; $j++; } $s->{-affected} =$j; rmiTrigger($s, $a, $r, undef, '-recIns1C', $j ==1 ? ('-recForm1C') : ()) if $r; $r =$r ||$d; } else { # insert single record rmiTrigger($s, $a, $d, undef, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recIns0R -recInsID -recChg0W)); rfdCp ($s, $p, $a, $d) if !$a->{-file} && $p && $p->{-file}; rfdCp ($s, $a->{-file}, $a, $d) if $a->{-file}; rmiIndex ($s, $a, $d, undef) if $m->{-index} ||$s->{-index}; $r =$s->dbiIns($a, $d); rfdStamp ($s, $a, $r, $tu); $r->{-editable} =1 if $r && $s->{-rac} && ($m->{-racWriter}||$s->{-racWriter}); $s->{-affected} =1; do { local $a->{-cmd} ='recRead'; rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recFlim0R -recRead0R -recIns1R -recRead1R)) } if $r; rmiTrigger($s, $a, $r, undef, qw(-recIns1C -recRead1C -recForm1C)) if $r; } return($r) } sub dbiTblExpr {# DBI / SQL table name expression !$_[0]->{-table}->{$_[1]} || !$_[0]->{-table}->{$_[1]}->{-expr} ? $_[1] : $_[0]->{-table}->{$_[1]}->{-expr} =~/\s/ ? $_[0]->{-table}->{$_[1]}->{-expr} : $_[0]->{-table}->{$_[1]}->{-expr} .' AS ' .$_[1] } sub dbiTblExp1 {# DBI / SQL first table expression for insert/update/delete !$_[0]->{-table}->{$_[1]} || !$_[0]->{-table}->{$_[1]}->{-expr} ? $_[1] : $_[0]->{-table}->{$_[1]}->{-expr} =~/^([^\s]+\s+AS\s+[^\s]+)/i ? $1 : $_[0]->{-table}->{$_[1]}->{-expr} =~/\s/ ? $` : $_[0]->{-table}->{$_[1]}->{-expr} # .' AS ' .$_[1] # sql syntax } sub dbiIns { # Insert record into database # -table=>table, field=>value # -save=>boolean, -sel=>boolean my ($s, $a, $d) =@_; my $f =$a->{-table}; my @c; my $r =$a; $s->{-affected} =0; if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') { my $db=$s->dbi(); my @a =recFields($s,$d); my @v; @c=( 'INSERT INTO ' .dbiTblExp1($s, $f) .' (' .join(',', @a) .') VALUES (' .join(',' , $s->{-dbiph} ? map {'?'} @a : map {mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_}) } @a) .')' , $s->{-dbiph} ? ({}, map {$d->{$_}} @a) : () ); $s->logRec('dbiIns', @c); $db->do(@c)|| return(&{$s->{-die}}($s->lng(0,'dbiIns') .": do() -> " .($DBI::errstr ||'Unknown') .$s->{-ermd}) && undef); $s->{-affected} =$DBI::rows; $s->{-affected} =-$s->{-affected} if $s->{-affected} <0; return($d) if ($s->{-affected} >1) ||$a->{-save}; return($d) if defined($a->{-sel}) && !$a->{-sel}; if ($s->{-dbiph}) { @a =grep {defined($d->{$_})} @a; @v =map {$d->{$_}} @a; } @c =('SELECT * FROM ' .dbiTblExp1($s, $f) .' WHERE ' .join(' AND ' , $s->{-dbiph} ? map {"$_=?"} @a : map {defined($d->{$_}) ? ($_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_})) : () } @a)); $s->logRec('dbiIns', @c, @v ? {} : (), @v); $f =$db->prepare(@c); $r =$f && $f->execute(@v) && $f->fetchrow_hashref() || return(&{$s->{-die}}($s->lng(0,'dbiIns') .": selectrow_hashref() -> " .($DBI::errstr||'Empty result set') .$s->{-ermd}) && undef); } elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') { @c = ([map {$d->{$_}} @{$s->{-table}->{$f}->{-key}}] ,($r =recData($s, $d))); $s->logRec('dbiIns','kePut', $f, @c); $s->dbmTable($f)->kePut(@c) || return(&{$s->{-die}}($s->lng(0,'dbiIns') .": kePut() -> $@" .$s->{-ermd}) && undef); $s->{-affected} =1; } elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'xmr') { } $r } sub dbiExplain {# Explain DML plan my $s =shift; return() if !$s->{-debug} || (defined($s->{-dbiexpl}) && !$s->{-dbiexpl}); my $i =ref($_[0]) ? shift : $s->dbi; my $q =shift; eval { my $c =$i->prepare("explain $q"); $c->execute; my $r; while ($r =$c->fetchrow_hashref()) { $s->logRec('dbiExplain', join(', ', map {"$_=> " .$s->strquot($r->{$_})} @{$c->{NAME}})); } } } sub recUpd { # Update record(s) in database # -table=>table, field=>value || -data=>{values} # -key=>{field=>value}, -where=>'condition', -version=>'+'|'-' # -optrec=>boolean, -sel=>boolean my $s =$_[0]; $s->varLock if $s->{-serial} && $s->{-serial} ==2; $s->logRec('recUpd', @_[1..$#_]); my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]}); my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a; $a->{-cmd} ='recUpd'; $a->{-table}=recType ($s, $a, $d); $a->{-key} =rmlKey ($s, $a, $d); my $m =mdeTable($s,$a->{-table}); my $r =undef; my $w =mdeWriters($s, $m); my $u =$m->{-rvcChgState} ||$s->{-rvcChgState}; my $o =$m->{-rvcCkoState} ||$s->{-rvcCkoState}; my $x =$m->{-rvcDelState} ||$s->{-rvcDelState}; my $v =$m->{-rvcActPtr} ||$s->{-rvcActPtr}; my $tu=time(); my $t1=$m->{-rvcUpdWhen} ||$s->{-rvcUpdWhen}; my $t2=$m->{-rvcVerWhen} ||$s->{-rvcVerWhen}; my $i =$m->{-index} ||$s->{-index}; my $b =$m->{-rfa} ||$s->{-rfa}; my $e; local $a->{-version}= ref($a->{-version}) ? $a->{-version} : $v && (!$a->{-version} ||$a->{-version} eq '-') ? [$v, @{$x||[]}] : ($a->{-version} ||'+'); foreach my $w (qw(-rvcInsBy -rvcInsWhen)) {foreach my $c ($m, $s) { next if !$c->{$w}; delete $d->{$c->{$w}}; last }} foreach my $c ($m, $s) { next if !$c->{-rvcUpdBy}; $d->{$c->{-rvcUpdBy}} =$s->user; last } $d->{$t1} =$s->strtime($tu) if $t1; rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recUpd0C)); if ($w ||$o ||$v ||$i ||grep {$s->{$_} || $m->{$_}} qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recChg0W -recUpd1R)) { my $c =$s->recSel(rmlClause($s, $a), -data=>undef); my $j =0; while ($r =$c->fetchrow_hashref()) { $j++; return(&{$s->{-die}}($s->lng(0,'recUpd') .": $j ". $s->lng(1,'-affected') .$s->{-ermd}) && undef) if $s->{-affect} && $j >$s->{-affect}; # $r ={%$r}; # readonly hash, should be considered below return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recUpd') .': ' .$s->lng(1,'recUpdAclStp') .$s->{-ermd}) && undef) if $w && !$s->ugmember(map {$r->{$_}} @$w); rfdStamp($s, $a, $r) if $b; my ($n, $p); if (($v && $r->{$v} # prohibit version && (!$o || (defined($r->{$o->[0]}) && ($r->{$o->[0]} ne $o->[1])))) || ($x && defined($r->{$x->[0]}) && ($r->{$x->[0]} eq $x->[1]) && (!defined($d->{$x->[0]}) || ($d->{$x->[0]} eq $x->[1]))) ) { return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recUpd') .': ' .$s->lng(1,'recUpdVerStp') .$s->{-ermd}) && undef) } elsif ($o # check-in && (($r->{$o->[0]}||'') eq $o->[1]) && defined($d->{$o->[0]}) && ($d->{$o->[0]} ne $o->[1]) && (!$x || (defined($d->{$x->[0]}) && ($d->{$x->[0]} ne $x->[1]))) && $r->{$v}) { my $t =$r->{'id'}; $e =$s->recUpd(%$r, %{recData($s,$d)} , 'id'=>$r->{$v} , $v=>undef , -table=>$a->{-table} , -key=>{'id'=>$r->{$v}}); rfdRm ($s, $a->{-table}, $r) if $r->{-file}; rmiIndex($s, $a, undef, $r) if $i; $s->dbiDel({-table=>$a->{-table}, -key=>{'id'=>$t}}); $n =undef; } elsif ($o # check-out && (($r->{$o->[0]}||'') ne $o->[1]) && (($d->{$o->[0]}||'') eq $o->[1])) { $n ={%$r}; @{$n}{recFields($s, $d)} =recValues($s, $d); $n->{$v} =$r->{'id'}; rmiTrigger($s, $a, $n, $n, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recInsID -recChg0W)); rfdCp ($s, $r->{-file}, $a, $n) if $r->{-file}; rfdStamp ($s, $a, $n, $tu) if $r->{-file}; rmiIndex ($s, $a, $n, undef) if $m->{-index} ||$s->{-index}; $e =$s->dbiIns($a, $n); $e->{-file} =$n->{-file} if $n->{-file}; $n =undef; } elsif ($v && (!$u # version || (defined($r->{$u->[0]}) && !grep {$r->{$u->[0]} eq $_ } @{$u}[1..$#{@$u}]))) { $n ={%$r}; @{$n}{recFields($s, $d)} =recValues($s, $d); $p ={%$r, $v=>$r->{'id'}, -table=>$a->{-table}}; rmiTrigger($s, $a, $n, $r, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recChg0W)); rmiTrigger($s, $a, $p, undef, qw(-recInsID)); do { rfdCp ($s, $r->{-file}, $a, $p); rfdStamp($s, $a, $p, rfdTime($s, $a, $n)||'+'); } if $r && $r->{-file} && (!$u || $a->{-file} || ($d->{$u->[0]} && grep {$d->{$u->[0]} eq $_ } @{$u}[1..$#{@$u}])); do { rfdRm ($s, $a->{-table}, $n); rfdCp ($s, $a->{-file}, $a->{-table}, $n); rfdCln ($s, $a->{-table}, $n) } if $a->{-file} && (!$r->{-file} || $r->{-file} ne $a->{-file}); rfdStamp ($s, $a, $n, rfdTime($s, $a, $n)||'+'); $p->{$t2} =$d->{$t1} if $t2 && $t1 && (exists($r->{$t2}) || ($m->{-mdefld} && $m->{-mdefld}->{$t2}) || (($m->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm')); rmiIndex ($s, $a, $n, $r) if $i; rmiIndex ($s, $a, $p) if $i; $p =$s->dbiIns({-table=>$a->{-table}, -save=>1}, $p); } else { # update only $n ={%$r}; @{$n}{recFields($s, $d)} =recValues($s, $d); rmiTrigger($s, $a, $n, $r, qw(-recForm0R -recFlim0R -recEdt0R -recChg0R -recUpd0R -recChg0W)); do { rfdRm ($s, $a->{-table}, $n); rfdCp ($s, $a->{-file}, $a->{-table}, $n); } if $a->{-file} && (!$r->{-file} || ($r->{-file} ne $a->{-file})); rfdStamp ($s, $a, $n, $tu) if $r && $r->{-file}; rfdCln ($s, $a, $n) if $r && $r->{-file} && $u && $n->{$u->[0]} && !grep {$n->{$u->[0]} eq $_ } @{$u}[1..$#{@$u}]; rmiIndex ($s, $a, $n, $r) if $i; } if (1 && $n) { $s->logRec('dbiUpd','SINGLE') if $j ==1; $e =$s->dbiUpd({ -table=>$a->{-table} ,-key=>$s->recWKey($a->{-table}, $r) # recKey, recWKey }, $n, $r || {}); $s->{-affected} =$j if $s->{-affected}; } } $r =$e || $s->dbiUpd($a, $d); } else { $r =$s->dbiUpd($a, $d); } return(&{$s->{-die}}($s->lng(0,'recUpd') .': ' .($s->{-affected}||0) .' ' .$s->lng(1,'-affected') .$s->{-ermd}) && undef) if $s->{-affect} && (($s->{-affected}||0) != $s->{-affect}); if ($r && ($s->{-affected}||0) ==1) { rfdStamp($s, $a, $r) if $b; $r->{-editable} =$w ? $s->ugmember(map {$r->{$_}} @$w) : 1 if $s->{-rac}; { local $a->{-cmd} ='recRead'; rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recFlim0R -recRead0R -recRead1R)) }; rmiTrigger($s, $a, $r, undef, qw(-recUpd1C -recRead1C -recForm1C)); } elsif ($r) { rmiTrigger($s, $a, $r, undef, qw(-recUpd1C)) } $r } sub recUtr { # Translate values in database # (table || {cmd} ||false, field, new, old) # {-table, -version} # or recUpd() args my $s =$_[0]; my $n =$_[1]; $n =$s->{-pcmd}->{-table} ||$s->{-pcmd}->{-form} if !$n; $n->{-table} = $s->{-pcmd}->{-table} if ref($n) && !$n->{-table}; my $a; if ($n && ($n !~/^-/)) { $a ={-table=>ref($n) ? $n->{-table} : $n , -key=>{}, -data=>{}, -sel=>0}; if (!$_[4] && ref($_[2]) && ref($_[3])) { # {new}, {old} $a->{-data}=$_[2]; $a->{-key} =$_[3]; } elsif (!$_[2] && ref($_[3]) && ref($_[4])) { # !, {new}, {old} $a->{-data}=$_[3]; $a->{-key} =$_[4] } elsif (ref($_[2]) eq 'HASH') { # {field/src} foreach my $k (keys %{$_[2]}) { if (ref($_[2]->{$k})) { # {field=>[new, old]} $a->{-data}->{$k} =$_[2]->{$k}->[0]; $a->{-key}->{$k} =$_[2]->{$k}->[1] } else { # {src fld=>tgt fld}, {new}, {old} $a->{-data}->{$_[2]->{$k}} =$_[3]->{$k}; $a->{-key}->{$_[2]->{$k}} =$_[4]->{$k}; } } } elsif (ref($_[2])) { # [fields], [new], [old] for (my $i=0; $i <=$#{$_[2]}; $i++) { $a->{-data}->{$_[2]->[$i]} =$_[3]->[$i]; $a->{-key}->{$_[2]->[$i]} =$_[4]->[$i] } } elsif ($_[2] && !ref($_[2])) { # field, new, old $a->{-data}->{$_[2]}=$_[3]; $a->{-key}->{$_[2]} =$_[4]; } else { return(&{$s->{-die}}("'recUtr' parameters unknown" .$s->{-ermd}) && undef); } if ((grep {!defined($a->{-data}->{$_})} keys %{$a->{-data}}) || (grep {!defined($a->{-key}->{$_})} keys %{$a->{-key}})){ return(undef) } } else { $a = (@_< 3 && ref($n) ? {%{$n}} : {@_[1..$#_]}); } $s->varLock if $s->{-serial} && $s->{-serial} ==2; $s->logRec('recUtr', @_[1..$#_]); my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a; $a->{-cmd} ='recUtr'; $a->{-table}=recType ($s, $a, $d); $a->{-key} =rmlKey ($s, $a, $d); my $m =mdeTable($s,$a->{-table}); my $x =$m->{-rvcDelState} ||$s->{-rvcDelState}; my $v =$m->{-rvcActPtr} ||$s->{-rvcActPtr}; local $a->{-version}= ref($n) ? $n->{-version} ||'-' : '-'; # !!! ignoring chk-out $a->{-version}= ref($a->{-version}) ? $a->{-version} : $v && (!$a->{-version} ||$a->{-version} eq '-') ? [$v, @{$x||[]}] : ($a->{-version} ||'+'); if (ref($n) && $n->{-excl} && $n->{-version} && $v && $a->{-version} && (ref($_[4]) eq 'HASH')) { my $kv =$s->recKey($a->{-table}, $_[3]); $a->{-where} = join(' AND ' , map { defined($kv->{$_}) ? ('(' .$_ .'!=' .$s->mdeQuote($a->{-table},$_,$kv->{$_}) .')' ,"($v IS NULL OR " . $v .'!=' .$s->mdeQuote($a->{-table},$_,$kv->{$_}) .')') : () } keys %$kv); } local $s->{-rac} =undef; $s->dbiUpd($a, $d); } sub dbiUpd { # Update record(s) in database # -table=>table, field=>value || -data=>{values} # -key=>{field=>value}, -where=>'condition' # -save=>boolean, -optrec=>boolean, -sel=>boolean # $d && $dp - single record full new && prev data my ($s, $a, $d, $dp) =@_; my $f =$a->{-table}; my @c; my $r =undef; $s->{-affected} =0; if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') { $d ={map { (defined($dp->{$_}) && defined($d->{$_}) && ($dp->{$_} eq $d->{$_})) || (!defined($dp->{$_}) && !defined($d->{$_})) ? () : ($_ => $d->{$_}) } keys %$d} if $dp; $d =$dp if $dp && !scalar(keys(%$d)); my $db =$s->dbi(); my @cn =!$a->{-key} ? () : $s->{-dbiph} ? sort keys %{$a->{-key}} : keys %{$a->{-key}}; my(@a, @v); @a =recFields($s,$d) if $s->{-dbiph}; @c=('UPDATE ' .dbiTblExp1($s, $f) .' SET ' .join(',' , $s->{-dbiph} ? (map {"$_=?"} @a) : (map {$_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_}) } recFields($s,$d))) ." WHERE " .join(' AND ' , dbiKeyWhr($s, 1, $a, @cn) # Key condition , $a->{-where} ? '(' .$a->{-where} .')' # Where condition : () , ref($a->{-version}) # Version control $f. ? ("(( " .$a->{-version}->[0] .' IS NULL' ." OR " .$a->{-version}->[0] ."='')" .($a->{-version}->[1] ? ' AND ' .$a->{-version}->[1] ." <> '" .$a->{-version}->[2] ."')" : ')')) : () , dbiACLike($s, 1, $f, undef # Access control ,mdeWriters($s, $f), $s->ugnames()) ) ,$s->{-dbiph} ? ({}, (map {$d->{$_}} @a), (map {ref($a->{-key}->{$_}) ? @{$a->{-key}->{$_}} : $a->{-key}->{$_}} @cn)) : () ); $s->logRec('dbiUpd', @c); $db->do(@c) || return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": do() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef); $s->{-affected} =$DBI::rows; $s->{-affected} =-$s->{-affected} if $s->{-affected} <0; $s->logRec('dbiUpd','AFFECTED',$s->{-affected}); return($s->dbiIns($a, $d)) if !$s->{-affected} && ($a->{-save} || $s->{-table}->{$f}->{-ixcnd}); return($s->recIns($a, $d)) if !$s->{-affected} && ($a->{-optrec} || $s->{-table}->{$f}->{-optrec}); return($d) if ($s->{-affected} >1) ||$a->{-save}; return($d) if defined($a->{-sel}) && !$a->{-sel}; return($d) if !$s->{-affect} && $DBI::rows <=0; if ($s->{-dbiph}) { @cn =grep {defined($d->{$_}) || !exists($d->{$_}) && defined($a->{-key}->{$_}) } @cn; @v =map {defined($d->{$_}) ? $d->{$_} : $a->{-key}->{$_} } @cn; } @c =('SELECT * FROM ' .dbiTblExp1($s, $f) .' WHERE ' .join(' AND ' , $s->{-dbiph} ? (map { "$_=?" } @cn) : (map { defined($d->{$_}) ? ($_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $d->{$_})) : exists($d->{$_}) ? () : defined($a->{-key}->{$_}) ? ($_ .'=' .mdeQuote($s, $s->{-table}->{$f}, $_, $a->{-key}->{$_})) : () } @cn) , $a->{-where} ? '(' .$a->{-where} .')' : ()) ); $s->logRec('dbiUpd', @c, @v ? {} : (), @v); $f =$db->prepare(@c); $r =$f && $f->execute(@v) && $f->fetchrow_hashref() || return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": selectrow_hashref() -> " .($DBI::errstr||'Empty result set') .$s->{-ermd}) && undef); } elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') { my ($j, $h, @f, @v); $j =0; $h =$s->dbmTable($f); if (!$dp) { @f =recFields($s,$d); @v =recValues($s,$d); } $s->{-affected} = !$dp ? $s->dbmSeek($a, sub { $j++; return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": $j ". $s->lng(1,'-affected') .$s->{-ermd}) && undef) if $s->{-affect} && $j >$s->{-affect}; if (!$dp) { $r =$_[2]; @{$r}{@f} =@v } else { $r =$d } my $k =[map {$r->{$_}} @{$s->{-table}->{$f}->{-key}}]; $s->logRec('dbiUpd','kePut', $f, $k, $_[1], $r); $h->kePut($k, $_[1], $r); }) : do { my $k =[map {$d->{$_}} @{$s->{-table}->{$f}->{-key}}]; my $kp=[map {$dp->{$_}} @{$s->{-table}->{$f}->{-key}}]; $s->logRec('dbiUpd','kePut', $f, $k, $kp, $d); $h->kePut($k, $kp, $d); $r =$d; 1 }; if (!$s->{-affected}) { return($s->dbiIns($a, $d)) if $a->{-save} || $s->{-table}->{$f}->{-ixcnd}; return($s->recIns($a, $d)) if $a->{-optrec} || $s->{-table}->{$f}->{-optrec}; return(&{$s->{-die}}($s->lng(0,'dbiUpd') .": dbiSeek() -> " .($@ ||'not found') .$s->{-ermd}) && undef) } $r =$s->{-affected} >1 ? $d : $r; } $r } sub dbmSeek { # Select records from dbm file using -key and -where my ($s, $a, $e) =@_; my $m =$s->{-table}->{$a->{-table}}; # metadata my $i =$m->{-key}; # index my $k =($a->{-key} # key index part ? [map {!exists($a->{-key}->{$_}) ? () : ref($a->{-key}->{$_}) ? () : ($a->{-key}->{$_}) } @$i] : []); my $ko=$s->{-keyqn}; # key compare opt my $wk={ $a->{-key} # key where part ? (map {($_=>$a->{-key}->{$_}) } (grep { my $v =$_; ref($a->{-key}->{$v}) || !grep {$v eq $_ } @$i } keys %{$a->{-key}})) : () }; $wk=undef if !%$wk; my $o =($a->{-keyord} ||$a->{-orderby} ||$a->{-order}) # order request || (!$e && (!@$k) ? $KSORD : '-aeq'); $o ='-' .$o if substr($o,0,1) ne '-'; my $ox=@$k # order execute ? $o : $e ? $o : $o =~/^-[af]/ ? '-aall' : '-dall'; my $ws; # 'where' key cond if ($wk) { # !!! without [{}] syntax $ws =substr($o, 2); # of cgiForm(recQBF)/cgiQkey $ws =0 ? undef : $ws eq 'eq' || $ws eq 'all' ? sub{my($k,$v,$d); foreach $k (keys %$wk) { $v =$wk->{$k}; $d =$_[2]->{$k}; return(undef) if $ko && (!defined($v) || ($v eq '')) ? defined($d) && $d ne '' : !defined($d) ? defined($v) : !defined($v) ? defined($d) : ref($v) ? !grep {$d eq $_} @$v : $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/ ? $d != $v : $d ne $v; }; 1} : $ws eq 'ge' ? sub{my($k,$v,$d); foreach $k (keys %$wk) { $v =$wk->{$k}; $d =$_[2]->{$k}; return(undef) if $ko && (!defined($v) || ($v eq '')) ? defined($d) && ($d lt '') : !defined($d) ? defined($v) : !defined($v) ? 0 : ref($v) ? !grep {$d ge $_} @$v : $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/ ? $d < $v : $d lt $v; }; 1} : $ws eq 'gt' ? sub{my($k,$v,$d); foreach $k (keys %$wk) { $v =$wk->{$k}; $d =$_[2]->{$k}; return(undef) if $ko && (!defined($v) || ($v eq '')) ? !defined($d) || ($d le '') : !defined($d) ? 1 : !defined($v) ? !defined($d) : ref($v) ? !grep {$d gt $_} @$v : $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/ ? $d <= $v : $d le $v; }; 1} : $ws eq 'le' ? sub{my($k,$v,$d); foreach $k (keys %$wk) { $v =$wk->{$k}; $d =$_[2]->{$k}; return(undef) if $ko && (!defined($v) || ($v eq '')) ? defined($d) && ($d gt '') : !defined($d) ? 0 : !defined($v) ? defined($d) : ref($v) ? !grep {$d le $_} @$v : $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/ ? $d > $v : $d gt $v; }; 1} : $ws eq 'lt' ? sub{my($k,$v,$d); foreach $k (keys %$wk) { $v =$wk->{$k}; $d =$_[2]->{$k}; return(undef) if $ko && (!defined($v) || ($v eq '')) ? !defined($d) || ($d ge '') : !defined($d) ? !defined($v) : !defined($v) ? 0 : ref($v) ? !grep {$d lt $_} @$v : $d =~/^[\d\.]+\$/ && $v =~/^[\d\.]+\$/ ? $d >= $v : $d ge $v; }; 1} : undef } my $wr=$a->{-urole} # 'where' role cond && mdeRole($s, $m, $a->{-urole}); if ($wr) { my $wl =$wr; my $wn =$a->{-uname} ? $s->ugnames($a->{-uname}) : $s->ugnames(); my $wx =$a->{-urole} =~/^(?:manager|principal|user)$/i ? mdeRole($s, $m, 'actor') : $a->{-urole} =~/^(?:managers|principals|users)$/i ? mdeRole($s, $m, 'actors') : []; $wr =sub { foreach my $n (@$wn) { foreach my $v (@$wx) { return(undef) if $_[2]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i } foreach my $v (@$wl) { return($n) if $_[2]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i } } undef } } my $wa=$a->{-urole} && !$a->{-uname} # 'where' access cond ? undef : mdeReaders($s, $m); my $wv=$a->{-version}; # 'where' version cond $wv=undef if !ref($wv) || !@$wv; my $ft=$a->{-ftext}; # full-text find my $wf=$a->{-filter}; # 'where' filter expr my $wc=$a->{-where}; # 'where' condition my $we=$wc; # 'where' cond source if (defined($wc) && !ref($wc) && $wc) { # ... from string # !!! SQL perl operations incompatible with perl my $wm =$we; $we =''; my ($wa, $wt, $wq); while (length($wm)) { $wa =!$wa; if ($wm =~/(?<=])=)/'=' .$1/ge; $wt =~s/({\w+\})/'$_->' .$1/ge; $wt =~s/\b((?{' .$v .'}' : $v/ge; } # !!! good expr syntax? $we .=$wt .$wq; } $wc =$s->ccbNew($we); } my $w =sub{local $_ =$_[2]; # 'where' construct (!$wv || (!$_[2]->{$wv->[0]} && (!$wv->[1] ||!$_[2]->{$wv->[1]} ||($_[2]->{$wv->[1]} ne $wv->[2])))) && (!$ws || &$ws(@_)) && (!$wc || &$wc(@_)) && (!$wa || ugmember($s, map {$_[2]->{$_}} @$wa)) && (!$wr || &$wr(@_)) && (!$ft || grep {defined($_[2]->{$_}) && $_[2]->{$_} =~/\Q$ft\E/i} keys %{$_[2]}) && (!$wf || &$wf(@_)) }; $s->logRec('dbiSeek' , $a->{-table}, $ox, $k , $wv ? (-version=> $wv) : () , $wk ? ('-' .substr($o, 2)=>$wk) : () , $we ? (-where=>$we) : () , $wa ? (-rac =>$wa) : () , $wr ? (-urole=>$a->{-urole}, -uname=>$a->{-uname}||'') : () , $ft ? (-ftext=>$ft) : () , $wf ? (-filter=>$wf) : () , $e ? (-subw=>$e) : () ); !$s->{-c}->{-dbmSeek} ? $s->dbmTableFlush($a->{-table}) # !!! for proper seek by DB_File : $s->dbmTable($a->{-table})->sync(); local $s->{-c}->{-dbmSeek} =1; $s->dbmTable($a->{-table})->keSeek($ox,$k,$w,$e); } sub dbiKeyWhr { # SQL -key -order query condition # self, tbl alias off, {command}, key field names my ($s, $t, $a, @cn)=@_; @cn =!$a->{-key} ? () : $s->{-dbiph} ? sort keys %{$a->{-key}} : keys %{$a->{-key}} if !@cn; !@cn && return(@cn); my $kc =$a->{-keyord} ||$a->{-order}; $kc =!$kc || ref($kc) || substr($kc,0,1) ne '-' ? '' : {'eq'=>'=','ge'=>'>=','gt'=>'>','le'=>'<=','lt'=>'<'}->{substr($kc,2)}||'='; $kc ='' if $kc eq '='; my $db =$s->dbi(); my $f =ref($a->{-table}) ? $a->{-table}->[0] : $a->{-table}; $f =$1 if $f=~/^([^\s]+)/; my $m =$s->{-table} && $s->{-table}->{$f}; $t =!$t && $m ? $f .'.' : ''; $s->{-dbiph} ?(map {my $ce =$m && $m->{-mdefld} && $m->{-mdefld}->{$_} && $m->{-mdefld}->{$_}->{-expr} || ($t .$_); # expression may not be in select list ref($a->{-key}->{$_}) ? do{ my $n =$_; @{$a->{-key}->{$_}} ? ('(' .join(' OR ' , map { ref($_) ? (do { local $a->{-key} =$_; local $_ =$_; local $s->{-dbiph} =undef; my @v =dbiKeyWhr(@_[0..2]); @v ? '(' .join(' AND ', @v) .')' : () }) : $s->{-keyqn} && (!defined($_) || ($_ eq '')) ? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='' OR " .$ce .'=?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'' OR " .$ce .$kc .'?)' : ('(' .$ce .$kc ."'' OR " .$ce .$kc .'?)')) : !defined($_) ? (!$kc ? '(' .$ce .' IS ?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'?)' : ('(' .$ce .$kc .'?)')) : ('(' .$ce .($kc ||'=') .'?)') } @{$a->{-key}->{$_}}) .')') : () } : $s->{-keyqn} && (!defined($a->{-key}->{$_}) || ($a->{-key}->{$_} eq '')) ? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='' OR " .$ce .'=?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'' OR " .$ce .$kc .'?)' : ('(' .$ce .$kc ."'' OR " .$ce .$kc .'?)')) : !defined($a->{-key}->{$_}) ? (!$kc ? '(' .$ce .' IS ?)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'?)' : ('(' .$ce .$kc .'?)')) : ('(' .$ce .($kc ||'=') .'?' .')') } @cn) :(map {my $ce =$m && $m->{-mdefld} && $m->{-mdefld}->{$_} && $m->{-mdefld}->{$_}->{-expr} || ($t .$_); # expression may not be in select list ref($a->{-key}->{$_}) ? do{ my $n =$_; @{$a->{-key}->{$_}} ? ('(' .join(' OR ' , map { ref($_) ? (do { local $a->{-key} =$_; local $_ =$_; my @v =dbiKeyWhr(@_[0..2]); @v ? '(' .join(' AND ', @v) .')' : () }) : $s->{-keyqn} && (!defined($_) || ($_ eq '')) ? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='')" : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'')" : ('(' .$ce .$kc ."'')")) : !defined($_) ? (!$kc ? '(' .$ce .' IS NULL)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'NULL)' : ($t .$n .$kc .'NULL')) : ('(' .$ce .($kc ||'=') .mdeQuote($s, $m, $n, $_) .')') } @{$a->{-key}->{$_}}) .')') : () } : $s->{-keyqn} && (!defined($a->{-key}->{$_}) || ($a->{-key}->{$_} eq '')) ? (!$kc ? '(' .$ce .' IS NULL OR ' .$ce ."='')" : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc ."'')" : ('(' .$ce .$kc ."'')")) : !defined($a->{-key}->{$_}) ? (!$kc ? '(' .$ce .' IS NULL)' : $kc =~/=/ ? '(' .$ce .' IS NULL OR ' .$ce .$kc .'NULL)' : ('(' .$ce .$kc .'NULL)')) : ('(' .$ce .($kc ||'=') .mdeQuote($s, $s->{-table}->{$f}, $_, $a->{-key}->{$_}) .')') } @cn); } sub dbiACLike { # SQL Access Control LIKE / RLIKE # self, tbl alias off, table, operation, [fields], [values], ?filter return(!$_[3] ? () : '') if !$_[4] ||!$_[5] || !@{$_[4]} ||!@{$_[5]}; # RLIKE method detect / construct my $o = ($_[0]->{-table} && $_[0]->{-table}->{$_[2]} && $_[0]->{-table}->{$_[2]}->{-dbiACLike}) || $_[0]->{-dbiACLike} ||''; # rlike regexp ~* similar regexp_like like eq|=; lc|lower; filter|sub # $o = 'eq lc'; my $t = !$_[1] && $_[0]->{-table} && $_[0]->{-table}->{$_[2]} && ($_[2] .'.') ||''; my $e = $_[0]->dbiEng(); $e = 0 ? '' : ($o =~/\b(?:rlike|regexp)\b/i)|| (!$o && ($e =~/\bDBI:(?:mysql)\b/i)) ? 'RLIKE' # MySQL, case insensitive for not binary strings : ($o =~/~\*/i) || (!$o && ($e =~/\bDBI:(?:pg|postgresql)\b/i)) ? '~*' # PostgreSQL, case insensitive : ($o =~/\b(?:similar)\b/i) ? 'SIMILAR TO' # SQL99, PostgreSQL: '%[[:<:]](|)[[:>:]]%' : ($o =~/\b(?:regexp_like)/i) ? 'REGEXP_LIKE' # Oracle 10: REGEXP_LIKE(zip, '[^[:digit:]]') : ''; my $l = !$e || ($o =~/\b(?:like|eq|=)\b/i) ? $_[5] : ($e eq 'SIMILAR TO' ? $_[0]->dbi->quote('%[[:<:]](' .join('|', map {$_[0]->dbiLikesc($_)} @{$_[5]}) .')[[:>:]]%') : $e eq 'RLIKE' ? $_[0]->dbi->quote( '(^|,|;)[:blank:]*(' .join('|', map {$_[0]->dbiLikesc($_)} @{$_[5]}) .')[:blank:]*(,|;|$)') : $_[0]->dbi->quote( '[[:<:]](' .join('|', map {$_[0]->dbiLikesc($_)} @{$_[5]}) .')[[:>:]]') ); $l = ref($l) ? (!$o || ($o =~/\b(?:lc|lower)\b/i) ? [map {lc($_)} @$l] : $l) : $e =~/\b(?:regexp_like)/i ? (',' .($o =~/\b(?:lc|lower)\b/i ? lc($l) : $l) .')') : (' ' .$e .' ' .($o =~/\b(?:lc|lower)\b/i ? lc($l) : $l)); if (ref($l) &&(@_ >6) # LIKE method '-filter' constructor && (!$o || ($o =~/\b(?:filter|sub)\b/i))) { my $w =$_[0]; my $e =$_[6]; my $f =$_[4]; $_[6] =$_[3] && $_[3] =~/not/i ? sub { foreach my $v (@$f) { next if !exists($_[3]->{$v}); foreach my $n (@$l) { return(undef) if defined($_[3]->{$v}) && $_[3]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i } } !$e || &$e(@_) } : sub { foreach my $v (@$f) { if (!exists($_[3]->{$v})) { if ($w) { # &{$w->{-warn}}("dbiACLike ACL filter ignoring due to ACL field(s) missing from SELECT list\n"); CORE::warn("dbiACLike ACL filter ignoring due to ACL field(s) missing from SELECT list\n"); $w =undef; } return(!$e || &$e(@_)) } foreach my $n (@$l) { return(!$e || &$e(@_)) if defined($_[3]->{$v}) && $_[3]->{$v} =~/(?:^|,|;)\s*\Q$n\E\s*(?:,|;|$)/i } } undef } } ' ' .($_[3] ? $_[3] .' ' : '') # RLIKE / LIKE assembly .(!defined($l) # !!! ignored -expr of field ? '' : !ref($l) && ($e =~/\b(?:regexp_like)\b/i) ? '(' .( $o =~/\b(?:lc|lower)\b/i ? join(' OR ', map {$e .'(LOWER(' .$t .$_ .')' .$l} @{$_[4]}) : join(' OR ', map {$e .'(' .$t .$_ .$l} @{$_[4]}) ) .')' : !ref($l) ? '(' .( $o =~/\b(?:lc|lower)\b/i ? join(' OR ', map {'LOWER(' .$t .$_ .')' .$l} @{$_[4]}) : join(' OR ', map {$t .$_ .$l} @{$_[4]}) ) .')' : $o =~/\b(?:eq|=)\b/i ? '(' .join(' OR ' , map { my $f =($o =~/\b(?:lc|lower)\b/i ? 'LOWER(' .$t .$_ .')' : ($t .$_)); map {$f .'=' .$_[0]->dbi->quote($_) } @$l } @{$_[4]}) .')' : '(' .join(' OR ' # !!! like precession, see -filter above , map { my $f =(!$o || ($o =~/\b(?:lc|lower)\b/i) ? 'LOWER(' .$t .$_ .')' : ($t .$_)); map {$f .' LIKE ' .$_[0]->dbi->quote('%' .$_ .'%') } @$l } @{$_[4]}) .')' ); } sub recDel { # Delete record(s) in database # -table=>table # -key=>{field=>value}, -where=>'condition', -version=>'+'|'-' my $s =$_[0]; $s->varLock if $s->{-serial} && $s->{-serial} ==2; $s->logRec('recDel', @_[1..$#_]); my $a =(@_< 3 && ref($_[1]) ? {%{$_[1]}} : {@_[1..$#_]}); my $d =$a->{-data} ? {%{$a->{-data}}} : exists($a->{-data}) ? {} : $a; $a->{-cmd} ='recDel'; $a->{-table}=recType($s, $a, $d); $a->{-key} =rmlKey($s, $a, $d); my $m =mdeTable($s,$a->{-table}); my $r =undef; my $w =mdeWriters($s, $m); my $x =$m->{-rvcDelState} ||$s->{-rvcDelState}; my $i =$m->{-index} ||$s->{-index}; my $b =$m->{-rfa} ||$s->{-rfa}; rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recDel0C)); if ((($w||$i) && !$x) ||grep {$s->{$_} || $m->{$_}} qw(-recDel0R -recDel1R)) { my $c =$s->recSel(rmlClause($s, $a), -data=>undef); my $j =0; while ($r =$c->fetchrow_hashref()) { $j++; return(&{$s->{-die}}($s->lng(0,'recDel') .": $j ". $s->lng(1,'-affected') .$s->{-ermd}) && undef) if $s->{-affect} && $j >$s->{-affect}; # $r ={%$r}; # readonly hash, should be considered below return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recDel') .': ' .$s->lng(1,'recDelAclStp') .$s->{-ermd}) && undef) if $w && !$s->ugmember(map {$r->{$_}} @$w); return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recDel') .': ' .$s->lng(1,'recUpdVerStp') .$s->{-ermd}) && undef) if $x && defined($r->{$x->[0]}) && ($r->{$x->[0]} eq $x->[1]); rfdStamp ($s, $a, $r) if $b; rmiTrigger($s, $a, undef, $r, qw(-recForm0R -recFlim0R -recDel0R)); rfdRm ($s, $r) if !$x && $r->{-file}; rmiIndex ($s, $a, undef, $r) if !$x && $i; } $r =($x ? $s->recUpd((map {$a->{$_} ? ($_=>$a->{$_}) : () } qw(-table -key -where -version)), @$x) : $s->dbiDel($a, $d)); } else { $r =($x ? $s->recUpd((map {$a->{$_} ? ($_=>$a->{$_}) : () } qw(-table -key -where -version)), @$x) : $s->dbiDel($a, $d)); } return(&{$s->{-die}}($s->lng(0,'recDel') .': ' .($s->{-affected}||0) .' ' .$s->lng(1,'-affected') .$s->{-ermd}) && undef) if $s->{-affect} && (($s->{-affected}||0) != $s->{-affect}); rmiTrigger($s, $a, $d, undef, qw(-recDel1C)) if $r; $r } sub dbiDel { # Delete record(s) in database # -table=>table # -key=>{field=>value}, -where=>'condition' my ($s, $a, $d) =@_; my $f =$a->{-table}; my @c; my $r; $s->{-affected} =0; if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') { @c =('DELETE FROM ' .dbiTblExp1($s, $f) .' WHERE ' .join(' AND ' , dbiKeyWhr($s, 1, $a) # Key condition , $a->{-where} ? '(' .$a->{-where} .')' # Where condition : () , dbiACLike($s, 1, $f, undef # Access control , mdeWriters($s, $f), $s->ugnames()) ) , $s->{-dbiph} && $a->{-key} ? ({}, map {ref($a->{-key}->{$_}) ? @{$a->{-key}->{$_}} : $a->{-key}->{$_}} sort keys %{$a->{-key}}) : () ); $s->logRec('dbiDel', @c); $s->dbi->do(@c) || return(&{$s->{-die}}($s->lng(0,'dbiDel') .": do() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef); $s->{-affected} =$DBI::rows; $s->{-affected} =-$s->{-affected} if $s->{-affected} <0; $s->logRec('dbiDel','AFFECTED',$s->{-affected}); return($s->{-affected} && $a); } elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') { my $h =$s->dbmTable($f); my $j =0; $s->{-affected} = $s->dbmSeek($a, sub { $j++; return(&{$s->{-die}}($s->lng(0,'dbiDel') .": $j " .$s->lng(1,'-affected') .$s->{-ermd}) && undef) if $s->{-affect} && $j >$s->{-affect}; $s->logRec('dbiDel', 'keDel', $f, $_[1]); $h->keDel($_[1]); }); return(&{$s->{-die}}($s->lng(0,'dbiDel') .": dbiSeek() -> $@" .$s->{-ermd}) && undef) if !defined($s->{-affected}); } $s->{-affected} && $a } sub dbiTrunc { # Clear all records in the datafile # self, datafile name my ($s, $f) =@_; my @c; if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') { @c =('TRUNCATE TABLE ' .dbiTblExp1($s, $f)); $s->logRec('dbiTrunc', @c); $s->dbi->do(@c) || return(&{$s->{-die}}($s->lng(0,'dbiTrunc') .": do() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef); } elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') { my $n =$s->pthForm('dbm',($s->{-table}->{$f} && $s->{-table}->{$f}->{-expr} ||$f)); if (-e $n) { $s->logRec('dbiTrunc','unlink', $n); unlink($n) || return(&{$s->{-die}}($s->lng(0,'dbiTrunc') .": unlink('$n') -> $!" .$s->{-ermd}) && undef) } } $s } sub recSel { # Select records from database # see 'dbiSel' my $s =$_[0]; my $a =@_< 3 && ref($_[1]) ? dsdClone($s, $_[1]) : {map {ref($_) ? dsdClone($s, $_) : $_} @_[1..$#_]}; $a->{-table}=recType($s, $a, $a); local $s->{-affect}=undef; my $m =mdeTable($s,$a->{-table}); $a->{-cmd} ='recSel'; $a->{-version}= ref($a->{-version}) ? $a->{-version} : $m && (!$a->{-version} ||$a->{-version} eq '-') ? [ ($m->{-rvcActPtr} ||$s->{-rvcActPtr} ||()) ,@{$m->{-rvcDelState} ||$s->{-rvcDelState} ||[]}] : ($a->{-version} ||'+'); local $a->{-urole}= !$a->{-urole} ||($a->{-urole} eq 'all') ? undef : $a->{-urole}; #$s->logRec('recSel', $a); $s->{-fetched} =0; rmiTrigger($s, $a, undef, undef, qw(-recSel0C)); my $r =$s->dbiSel($a); $r->{-query} =$a; $r } sub recList { # List records from database recSel(@_) # - reserved to be redesigned } sub recRead { # Read one record from database # -key=>{field=>value}, see 'dbiSel' # -wikn=>value, instead of -key # -optrec=>boolean, -test=>boolean my $s =$_[0]; my $a =@_< 3 && ref($_[1]) ? dsdClone($s, $_[1]) : {map {ref($_) ? dsdClone($s, $_) : $_} @_[1..$#_]}; my $d ={}; local $s->{-affect}=1; $a->{-cmd} ='recRead'; $a->{-table}=recType($s, $a, $d); $a->{-key} =rmlKey($s, $a, $d); $a->{-data} =ref($a->{-data}) ne 'ARRAY' ? undef : $a->{-data}; my $m =mdeTable($s,$a->{-table}); my $r =undef; rmiTrigger($s, $a, $d, undef, qw(-recForm0C -recRead0C)); $r =$s->recRead_($m, $a); rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recFlim0R -recRead0R -recRead1R -recRead1C -recForm1C)) if $r; $r } sub recRead_ { # recRead internal use, without triggers my ($s, $m, $a) =@_; my $r =$s->dbiSel($a)->fetchrow_hashref(); if ($r) { $s->{-affected} =1; $s->{-fetched} =1; } else { $s->{-affected} =0; $s->{-fetched} =0; return(undef) if $a->{-test}; return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recRead') .': ' .($s->{-affected}||0) .' ' .$s->lng(1,'-affected') .$s->{-ermd}) && undef) if !$a->{-optrec} || !$m->{-optrec}; return($s->recNew(map {($_=>$a->{$_})} grep {$a->{$_}} qw(-table -form))); } if ($r && $s->{-rac}) { return(&{$s->{-die}}($s->{-ermu} .$s->lng(0,'recRead') .': '. $s->lng(1,'recReadAclStp') .$s->{-ermd}) && undef) if !$s->uadmrdr() &&($m->{-racWriter} ||$s->{-racWriter} ||$m->{-racReader} ||$s->{-racReader}) && !$s->ugmember(map {$r->{$_}} @{$m->{-racWriter} ||$s->{-racWriter}||[]} ,@{$m->{-racReader} ||$s->{-racReader}||[]}); $r->{-editable} =1 if $s->uadmwtr() || $s->ugmember(map {$r->{$_}} @{$m->{-racWriter} || $s->{-racWriter}||[]}) } rfdStamp($s, $a, $r) if $m->{-rfa} ||$s->{-rfa}; $r } sub recWikn { # Find record by name # (wikiname) my ($s, $val) =@_; my $rk; my $rl=0; my $ru=''; $s->logRec('recWikn',$val); foreach my $tn (keys %{$s->{-table}}) { my $tm =$s->mdeTable($tn); next if defined($tm->{-wikn}) && !$tm->{-wikn}; next if !$tm->{-wikn} && !$s->{-wikn}; my $fn; foreach my $f ($tm->{-wikn} ? (ref($tm->{-wikn}) ? @{$tm->{-wikn}} : $tm->{-wikn}) : (ref($s->{-wikn}) ? @{$s->{-wikn}} : $s->{-wikn})) { next if !$tm->{-mdefld}->{$f}; $fn =$f; last } next if !$fn; my $fv =$tm->{-rvcActPtr} ||$s->{-rvcActPtr}; my $fu =$tm->{-rvcUpdBy} ||$s->{-rvcUpdBy}; my $ti =$s->recSel(-table=>$tn , -version=>'+' , -key=>{$fn=>$val} , -keyord=>'dall'); my $rr; while ($rr=$ti->fetchrow_hashref()) { if ($rr->{$fv}) { next if $fu ? $ru gt ($rr->{$fu}||'') : $rl; $rk ={-table=>$tn, -key=>$s->recKey($tn,$rr)}; $ru =$rr->{$fu}||''; $rl =1; } else { $rk ={-table=>$tn, -key=>$s->recKey($tn,$rr)}; $rl =2; last } } last if $rl==2; } $rk } sub recHist { # History of changes of record # -table=>name, -key=>{} my $s =$_[0]; my $a =@_< 3 && ref($_[1]) ? dsdClone($s, $_[1]) : {map {ref($_) ? dsdClone($s, $_) : $_} @_[1..$#_]}; my $d ={}; local $s->{-affect}=undef; $a->{-cmd} ='recRead'; $a->{-table}=recType($s, $a, $d); $a->{-key} =rmlKey($s, $a, $d); my $m =mdeTable($s,$a->{-table}); $s->logRec('recHist',%$a); my %rvc =map {($_ => $m->{$_} ||$s->{$_}) } qw(-rvcInsBy -rvcInsWhen -rvcUpdBy -rvcUpdWhen -rvcActPtr); return(undef) if !$rvc{-rvcActPtr} || !$rvc{-rvcUpdWhen}; $rvc{-key} =$m->{-key} ||$s->{-key} ||$s->{-tn}->{-key}; $rvc{-key} =$rvc{-key}->[0] if ref($rvc{-key}); my $rva =$m->{-rvcActPtr} ||$s->{-rvcActPtr}; my %rvx =map {($m->{$_} ||$s->{$_} => 1) # may be included: -key, -rvcActPtr } qw(-rvcUpdBy -rvcUpdWhen -rvcActPtr); $rvx{$rvc{-key}} =1; $rvx{-fupd} =1; $rvx{-editable} =1; $a->{-key} ={$rvc{-key} => [$a->{-key}->{$rvc{-key}} , {$rvc{-rvcActPtr} => $a->{-key}->{$rvc{-key}}} ]}; $a->{-version} ='+'; $a->{-order} =$rvc{-rvcUpdWhen}; $a->{-keyord} ='-aeq'; # $s->logRec('recHist', %$a, {%rvc}); $s->{-affected}=0; $s->{-fetched} =0; my $l =0; # length my $r =[]; # return list my $pv={}; # previous values: field => value my $c =$s->recSel(%$a); my($r0, $r1) =($pv); while (my $rr =$c->fetchrow_hashref()) { # collect versions $r1 =$rr; if ($l >1024*1024*10) { push @$r, [$a->{-key}->{$rvc{-key}} , '...' , '...' , {}]; while (my $v =$c->fetchrow_hashref()) {$r1 =$v}; } $s->{-fetched}++; $s->{-affected}++; $s->rfdStamp($a->{-table}, $r1) if $m->{-rfa} ||$s->{-rfa}; rmiTrigger($s, $a, $r1, $r1, qw(-recForm0R -recRead0R -recRead1R -recRead1C -recForm1C)); push @$r, [ $r1->{$rvc{-key}} ,$r1->{$rvc{-rvcUpdWhen}} ,$r1->{$rvc{-rvcUpdBy}} ,{}]; foreach my $v (@{$r->[$#$r]}) { $l +=length($v) if !ref($v) && defined($v) } my $cf =$r->[$#$r]->[3]; foreach my $f (keys %$r1) { next if $rvx{$f} || (!defined($pv->{$f}) && !defined($r1->{$f})); next unless ($f ne $rva) ? (!defined($pv->{$f}) && defined($r1->{$f})) || ( defined($pv->{$f}) && !defined($r1->{$f})) || ($pv->{$f} ne $r1->{$f}) : 1; my $cv =$r1->{$f}; # change value if (!$cv) {} elsif ( (length($cv) >255) || ($cv =~/[\n\r]/) || ($m->{-mdefld} && $m->{-mdefld}->{$f} && $m->{-mdefld}->{$f}->{-inp} && (grep {$m->{-mdefld}->{$f}->{-inp}->{$_} } qw(-rows -arows -htmlopt))) ) { if ($m->{-mdefld} && $m->{-mdefld}->{$f} && $m->{-mdefld}->{$f}->{-inp} && $m->{-mdefld}->{$f}->{-inp}->{-htmlopt}) { $cv =$s->strDiff('-hbr', $pv->{$f}, $cv); } else { $cv =$s->strDiff('-br', $r0->{$f}, $cv); } } $cf->{$f} =$cv; $l +=length($cv) if defined($cv); # $s->logRec('recHist', $r1->{$rvc{-rvcUpdBy}}, $r1->{$rvc{-rvcUpdWhen}}, $f, $cv); $pv->{$f} =$r1->{$f}; } } # return($r); if (1) { # arrange attachments if possible my($fn, $ft); # folder name, folder time for (my $i=$#$r; $i >=0; $i--) { if ($fn && ( $r->[$i]->[3]->{-file} || ($r->[$i]->[1] lt $ft)) ){ $r->[$i+1]->[3]->{-file} =$fn; $fn =$ft =undef; } if ($r->[$i]->[3]->{-file}) { $fn =$r->[$i]->[3]->{-file}; $ft =$s->strtime($s->rfdTime($fn)||0); delete($r->[$i]->[3]->{-file}); } } $r->[0]->[3]->{-file} =$fn if $fn; } # $s->logRec('recHist', @$r); $r } sub recLast { # Last record lookup for values # self, table/command ||false, record data, key fields,... target # {-table, -version, -excl} my $s =$_[0]; my $n =$_[1]; $n =$s->{-pcmd}->{-table} ||$s->{-pcmd}->{-form} if !$n; $n->{-table} = $s->{-pcmd}->{-table} if ref($n) && !$n->{-table}; my $d =$_[2]; my $a ={-cmd=>'recLast' , -table=>ref($n) ? $s->recType($n, $d) : $n}; my $m =mdeTable($s,$a->{-table}); my $r =undef; return($r) unless ($m->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi'; local $s->{-affect}=1; $a->{-version} = ref($n->{-version}) ? $n->{-version} : $m && (!$n->{-version} ||$n->{-version} eq '-') ? [ ($m->{-rvcActPtr} ||$s->{-rvcActPtr} ||()) ,@{$m->{-rvcDelState} ||$s->{-rvcDelState} ||[]}] : ($n->{-version} ||'+'); if ($n->{-excl}) { my $kv =$s->recKey($a->{-table}, $_[2]); $a->{-where} = join(' AND ' , map { defined($kv->{$_}) ? $_ .'!=' .$s->mdeQuote($a->{-table},$_,$kv->{$_}) : () } keys %$kv); } foreach my $c ($m, $s) { next if !$c->{-rvcUpdWhen}; $a->{-order} =[[$c->{-rvcUpdWhen},'desc']]; last } for (my $i =$#_; $i >2; $i--) { next if ref($_[$i]) ne 'ARRAY'; $a->{-key} ={}; for (my $j =3; $j <=$i; $j++) { foreach my $f (@{$_[$j]}) { next if !defined($d->{$f}) || ($d->{$f} eq ''); $a->{-key}->{$f} =$d->{$f}; } } next if !%{$a->{-key}}; $s->logRec('recLast',$i , (map {($_=>$s->strdata($a->{$_}))} sort keys %$a) , @_[3..$#_]); rmiTrigger($s, $a, $d, $r, qw(-recForm0C -recRead0C)); $r =$s->dbiSel($a)->fetchrow_hashref(); next if !$r; # $s->{-affected} =$s->{-fetched} =1; rmiTrigger($s, $a, $r, $r, qw(-recForm0R -recRead0R -recRead1R -recRead1C -recForm1C)); if (ref($_[$#_]) eq 'CODE') { $r =$r && &{$_[$#_]}($s,$r); } elsif (ref($_[$#_]) eq 'ARRAY') { foreach my $f (@{$_[$#_]}) { $d->{$f} =$r->{$f} if defined($r->{$f}); } # $s->logRec('recLast', $i, map {($_=>$d->{$_})} @{$_[$#_]}); } last; } $r } sub recUnion { # UNION cursor / container operation # (self, option=>value,... {hash}||[array]||cursor,...) DBIx::Web::dbcUnion->new(@_[1..$#_]) } sub dbiSel { # Select records from database # -data =>[fields] | [field, [field=>alias], {-fld=>alias, -expr=>formula,..}] # -table =>[tables] | [[table=>alias], [table=>alias,join]] # -join[01] =>string # -join =>string # -join2 =>string # -key =>{field=>value} # -where =>string | [strings] # -ftext =>string # -version =>0|1 # -order =>string | [field, [field=>order]] # -keyord =>-(a|f|d|b)(all|eq|ge|gt|le|lt) # -group =>string | [field, [field=>order]] # -filter =>sub{}(cursor, undef, {field=>value,...}) my ($s, $a) =@_; my $t =$a->{-table}; my $f =ref($t) ? $t->[0] : $t; $f =$1 if $f=~/^([^\s]+)/; my @c; my $r; if (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') { # local $s->{-dbiph} =1 if !exists($s->{-dbiph}); my @cn =!$a->{-key} ? () : $s->{-dbiph} ? sort keys %{$a->{-key}} : keys %{$a->{-key}}; my @cv =!$a->{-key} ? () : $s->{-dbiph} ? map {ref($a->{-key}->{$_}) ? grep {!ref($_)} @{$a->{-key}->{$_}} : $a->{-key}->{$_}} @cn : (); my $kn =$s->{-table}->{$f} && $s->{-table}->{$f}->{-key} ||[]; my $tf =$s->{-table}->{$f} && $s->{-table}->{$f}->{-mdefld}; my $cf =$a->{-filter}; @c =('SELECT ' # Data . (!$a->{-data} ? ' * ' : !ref($a->{-data}) ? ' ' .$a->{-data} .' ' : ref($a->{-data}) ne 'ARRAY' ? ' * ' : join(', ' , map { my $v =ref($_) && $_ || $tf && $tf->{$_} || $_; !ref($v) ? ($v =~/\./ ? $v : "$f.$v AS $v") : ref($v) ne 'HASH' ? join(' AS ', @$v[0..1]) : (defined($v->{-expr}) ? $v->{-expr} .' AS ' .$v->{-fld} : $v->{-fld} =~/\./ ? $v->{-fld} : ($f .'.' .$v->{-fld} .' AS ' .$v->{-fld}) ) } @{$a->{-data}})) . ' FROM ' # From . ( $a->{-join0} ? $a->{-join0} .' ' : '') . (ref($t) ? join(' ' , (map {!ref($_) ? ($_,',') : (@$_, $_->[$#_] =~/(JOIN|,)$/i ? () : ',')} @$t)[0..-1]) : dbiTblExpr($s, $t) ) . ( $a->{-join1} ? $a->{-join1} : '') . join('' , map { !$a->{$_} ? () : $a->{$_} =~/^\s*(?:,|CROSS|JOIN|INNER|STRAIGHT_JOIN|LEFT|NATURAL|RIGHT|OUTER)\b/i ? (' ' .$a->{$_} .' ') : (', ' .$a->{$_} .' ') } qw(-join -join2) ) . ' WHERE ' # Where . join(' AND ' , dbiKeyWhr($s, 0, $a, @cn) # Key condition ,($a->{-where} # Where condition ? '(' .(!ref($a->{-where}) ? $a->{-where} : join(' AND ', map {$_ } @{$a->{-where}})) .')' : ()) ,(ref($a->{-version}) # Version switch ? ('((' .$f .'.' .$a->{-version}->[0] .' IS NULL OR ' .$f .'.' .$a->{-version}->[0] ."='')" .($a->{-version}->[1] ? " AND $f." .$a->{-version}->[1] ." <> '" .$a->{-version}->[2] ."')" : ')')) : ()) ,(($a->{-urole} && !$a->{-uname}) # Access control || $s->uadmrdr() ? () : dbiACLike($s, 0, $f, undef , mdeReaders($s, $f), $s->ugnames(), $cf) ) ,(!$a->{-urole} # Role filter ? () : dbiACLike($s, 0, $f, undef , mdeRole($s, $f, $a->{-urole}) ,($a->{-uname} ? $s->ugnames($a->{-uname}) : $s->ugnames()) , $cf)) ,(!$a->{-urole} ? () : $a->{-urole} =~/^(?:manager|principal|user)$/i ? dbiACLike($s, 0, $f, 'NOT' , mdeRole($s, $f, 'actor') ,($a->{-uname} ? $s->ugnames($a->{-uname}) : $s->ugnames()) , $cf) : $a->{-urole} =~/^(?:managers|principals|users)$/i ? dbiACLike($s, 0, $f, 'NOT' , mdeRole($s, $f, 'actors') ,($a->{-uname} ? $s->ugnames($a->{-uname}) : $s->ugnames()) , $cf) : ()) ,(!$a->{-ftext} # Full-text ? () : $s->{-table}->{$f}->{-ftext} ? '(' .join(' OR ' , map { ($_ =~/\./ ? $_ : "$f.$_") .' LIKE ' . $s->dbi->quote('%' .$a->{-ftext} .'%') } @{$s->{-table}->{$f}->{-ftext}} ) .')' : $s->{-table}->{$f}->{-field} ? '(' .join(' OR ' , map { ( $_->{-expr} ? $_->{-expr} : $_->{-fld} =~/\./ ? $_->{-fld} : ($f .'.' .$_->{-fld}) ) .' LIKE ' .$s->dbi->quote('%' .$a->{-ftext} .'%') } grep {ref($_) eq 'HASH' && $_->{-fld} && ($_->{-flg}||'') =~/[akwuql]/ && (!$_->{-expr} ||($_->{-expr} !~/[-+*\/!|&%\s()]/)) } @{$s->{-table}->{$f}->{-field}} ) .')' : ref($a->{-data}) eq 'ARRAY' ? '(' .join(' OR ' , map { (!ref($_) ?($_ =~/\./ ? $_ : "$f.$_") : ref($_) ne 'HASH' ? $_->[1] : (defined($_->{-expr}) ? $_->{-expr} : $_->{-fld} =~/\./ ? $_->{-fld} : ($f .'.' .$_->{-fld}) )) . ' LIKE ' .$s->dbi->quote('%' .$a->{-ftext} .'%') } grep {$_ && ((ref($_) ne 'HASH') || ($_->{-fld} && (!$_->{-expr} ||($_->{-expr} !~/[-+*\/!|&%\s()]/)))) } @{$a->{-data}} , $s->{-table}->{$f}->{-ftext} ? map { ($_ =~/\./ ? $_ : "$f.$_") .' LIKE ' .$s->dbi->quote('%' .$a->{-ftext} .'%') } @{$s->{-table}->{$f}->{-ftext}} : () ) .')' : ()) ,(scalar(@cn) ||$a->{-where} ||ref($a->{-version}) ||$a->{-urole} ||$a->{-ftext} ? () : ('1=1')) # !!! TRUE may be? But database dependent! ) . ($a->{-group} # Group by ? ' GROUP BY ' .(ref($a->{-group}) ? join(', ', map {!ref($_) ? $_ : join(' ',@$_)} @{$a->{-group}}) : $a->{-group}) : '') . ($a->{-order} # Order by ? ' ORDER BY ' .(ref($a->{-order}) ? join(', ' ,map { ref($_) ? join(' ',@$_) : $_ !~/[\s,]/ ? $_ .($a->{-keyord} && ($a->{-keyord} =~/^-[db]/) ? ' desc' : '') : $_ } @{$a->{-order}}) : $a->{-order} =~/^-[db]/ ? join(',', map {"$_ desc"} @$kn) : substr($a->{-order},0,1) eq '-' # $a->{-order}=~/^-[af]/ ? join(',', @$kn) : $a->{-order} !~/[\s,]/ ? $a->{-order} .($a->{-keyord} && ($a->{-keyord} =~/^-[db]/) ? ' desc' : '') : $a->{-order}) : $a->{-keyord} # -keyord ? ' ORDER BY ' .($a->{-keyord} =~/-[db]/ ? join(',', map {"$_ desc"} @$kn) : join(',', @$kn)) : '') . ($a->{-having} # Having ? ' HAVING ' .$a->{-having} : '' . ($a->{-limit} # Limit && $s->dbiEng('mysql') ? ' LIMIT ' .$a->{-limit} : '') ) ); $s->logRec('dbiSel', @c, @cv ? {} : (), @cv); $r =$s->dbi->prepare(@c) || return(&{$s->{-die}}($s->lng(0,'dbiSel') .": prepare() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef); $r->execute(@cv) || return(&{$s->{-die}}($s->lng(0,'dbiSel') .": execute() -> " .($DBI::errstr||'Unknown') .$s->{-ermd}) && undef); $r =DBIx::Web::dbiCursor->new($r, -flt=>$cf) if $cf || 1; # !!! DBI::st hides keys! $r->{-rec} ={map {($_ => undef)} @{$r->{NAME}}}; $r->{-rfr} =[map {\($r->{-rec}->{$_})} @{$r->{NAME}}]; $r->{-flt} =$cf; $r->bind_columns(undef, @{$r->{-rfr}}); $s->logRec('dbiSel', 'FETCH') if !$s->{-affect} || ($s->{-affect} >1); $s->dbiExplain(@c) if $s->{-debug} && $s->dbiEng('mysql'); } elsif (($s->{-table}->{$f}->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbm') { $r =$s->dbmSeek($a); return(&{$s->{-die}}($s->lng(0,'dbiSel') .": dbiSeek() -> $@" .$s->{-ermd}) && undef) if !defined($r); if ($a->{-data} && (ref($a->{-data}) eq 'ARRAY')) { $r->setcols($a->{-data}) } elsif (my $m =$s->{-table}->{$f}->{-field}) { $r->setcols(ref($m) eq 'HASH' ? keys %$m : map {$_->{-fld}} grep {(ref($_) eq 'HASH') && $_->{-fld}} @$m) } } $r } sub recCommit { # commit changes in the database $_[0]->logRec('recCommit'); if ($_[0]->{-dbi}) { $_[0]->{-dbi}->commit || ($DBI::errstr && return(&{$_[0]->{-die}}($_[0]->lng(0,'recCommit') .": commit() -> " .($DBI::errstr||'Unknown') .$_[0]->{-ermd}) && undef)) } $_[0] } sub recRollback {# rollback changes in the database $_[0]->logRec('recRollback'); if ($_[0]->{-dbi}) { $_[0]->{-dbi}->rollback || ($DBI::errstr && return(&{$_[0]->{-die}}($_[0]->lng(0,'recRollback') .": rollback() -> " .($DBI::errstr||'Unknown') .$_[0]->{-ermd}) && undef)) } $_[0] } ######################################################### # CGI User Interface ######################################################### sub cgiRun { # Execute CGI query my $s =$_[0]; my $r; local($s->{-pcmd}, $s->{-pdta}, $s->{-pout}); # Automatic upgrade if ($s->{-setup} && !$ARGV[0]) { my $ds =(stat(main::DATA))[9] ||0; my $dv =($ds && (stat($s->varFile()))[9])||0; $ARGV[0] ='-setup' if $ds >$dv; } # Command line service options if ($ARGV[0] && ($ARGV[0] =~/^-/)) { $s->start(); print "Content-type: text/plain\n\n"; print "'$0' service operation: '" .$ARGV[0] ."'...\n"; if ($ARGV[0] eq '-reindex') { $r =$s->recReindex(1); } elsif ($ARGV[0] eq '-setup') { $r =$s->setup(); $s->varStore(); } elsif ($ARGV[0] eq '-call') { $r =$ARGV[1]; $r =$s->$r(@ARGV[2..$#ARGV]); } # print "'$0' service operation: '" .$ARGV[0] ."'->$r\n"; $s->end(); return($s) } # Error display handler $s->{-ermu} ='/*User*/ '; $s->{-ermd} =' /*Trace*/ '; local $SELF =$s; my $he; $he =sub{ my $s =$SELF; if (!$s ||$s->ineval()) { if ($he && $s && $s->{-die} && ($he eq $s->{-die})) { # $SIG{__DIE__} ='DEFAULT'; CORE::die(@_) } return } delete $s->{-pcmd}->{-xml} if $s->{-pcmd}; my $e =join('',@_); chomp($e); my $ermu =$s->{-ermu}; if ($ermu && ($e =~/^\Q$ermu\E(.*)/)) {$e =$1} else {$ermu =undef} eval{$s->logRec('Die', $e)} if !$ermu; eval{$s->recRollback()}; $s->{-c}->{-httpheader} =$s->{-c}->{-httpheader} ||"Content-type: text/html\n\n" if *fatalsToBrowser{CODE}; eval{ $s->output($s->htmlStart()); local $s->{-pcmd}->{-cmd} ='frmErr'; local $s->{-pcmd}->{-cmg} ='frmHelp'; local $s->{-pcmd}->{-backc} =0; $s->output($s->htmlHidden(),$s->htmlMenu()); } if !$s->{-c}->{-htmlstart}; eval{ my $h2; my $ermd =$s->{-ermd}; if ($e =~/\Q$ermd\E/) { $h2 =$`; $e =$'; } elsif ($e =~/[\n\r]/) { $h2 =$`; $e =$'; if ($h2 =~/\s+(?:at\s+)*line\s+\d+\s+at\s+[^\s]+?\s+line\s+\d+\s*$/) { $h2 =$`; $e =$& ."\n\r" .$e } elsif ($h2 =~/\s+at\s+[^\s]+?\s+line\s+\d+$/) { $h2 =$`; $e =$& ."\n\r" .$e } } else { $h2 =$e; $e =''; } $e =~s/[\n\r]/
\n/g; $s->output('
' ,'

' , htmlEscape($s, lng($s, 0,'Error')), ' ' , htmlEscape($s, lng($s, 0, ($s->{-pcmd} && $s->{-pcmd}->{-cmd})||'Open')) , '@' , htmlEscape($s, lng($s, 0, ($s->{-pcmd} && $s->{-pcmd}->{-cmg})||'Start')) , "

\n" , $h2 ? '

' .$h2 ."

\n" : () , $e, "\n"); $s->cgiFooter(); $s->output("
\n",$s->htmlEnd())}; eval{$s->end()}; if ($he && $s->{-die} && ($he eq $s->{-die})) { # $SIG{__DIE__} ='DEFAULT'; if ($ermu) {goto cgiRunEND} else {CORE::die(@_)} }}; if (*fatalsToBrowser{CODE}) { !*CGI::Carp::set_message{CODE} && eval('use CGI::Carp'); $SIG{__DIE__} =\&CGI::Carp::die; CGI::Carp::set_message($he); } else { $SIG{__DIE__} =$he; } if (1 && ($ENV{GATEWAY_INTERFACE} && ($ENV{GATEWAY_INTERFACE} =~/PerlEx/))) { $SIG{__DIE__} ='DEFAULT'; $s->{-die} =$he; if ($s->{-serial}) { # prevent locking buzz $s->logRec('cgiRun', 'PerlEx', -serial =>0); $s->{-serial} =0; } } # Start operation $s->start(); $s->set(-autocommit=>0); local $s->{-affect} =1; # cmg transitions: # global commands # ------- -------- # recList: recList, recForm, recQBF-> # recQBF: recQBF, recForm, recList-> # recNew: recNew, recForm, recIns-> # recRead: recRead, recEdit, recForm, recIns, recUpd, recDel->, recNew-> # recDel: recForm # recForm? recForm # Accept & parse CGI params, find form, command, global command, key... $s->cgiParse(); local $s->{-pcmd}->{-ui} =1; my $oa =$s->{-pcmd}->{-cmd}; my $og =$s->{-pcmd}->{-cmg}; my $on =$s->{-pcmd}->{-form} ||'default'; my ($om, $oc); # Login redirection, if needed if ($s->{-pcmd}->{-login} && $s->uguest()) { print $s->cgi->redirect(-uri=>$s->urlAuth(), -nph=>(($ENV{SERVER_SOFTWARE}||'') =~/IIS/) ||($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER})); $s->end(); return($s); } # Navigation Search Pane or LEFT / RIGHT Frameset if ($s->{-pcmd}->{-search} && (length($s->{-pcmd}->{-search}) >1)) { $s->{-c}->{-search} =$s->{-pcmd}->{-search} } elsif ($s->{-search}) { $s->{-c}->{-search} =ref($s->{-search}) ? &{$s->{-search}}($s,$s->{-pcmd}) : $s->{-search}; delete $s->{-c}->{-search} if ($s->{-c}->{-search} =~/\b_frame=RIGHT\b/) && !$s->{-pcmd}->{-search} && ($on !~/^(?:default|start|index)$/); } if ($s->{-pcmd}->{-search} && ($s->{-c}->{-search} =~/\b_frame=RIGHT\b/)) { my $sch =$s->{-c}->{-search}; $sch =~s/\b_search=1\b/_search=0/; $sch =$s->url .$sch if $sch =~/^?/; $s->output('' , $s->cgi->header(-charset => $s->charset() ,-type => 'text/html') ,'{-lang} ? ' lang="' .$s->lang(0,'-lang') .'"' : '') .">\n\n" ,'' ,$s->{-title} ||$s->cgi->server_name() ,"\n" ,'' ."\n" ,'',"\n" ,'' ,'' ,'' ,'' ,'',"\n"); $s->end(); return($s) } # TOP / BOTTOM Frameset if ($s->{-pcmd}->{-frame} && ($s->{-pcmd}->{-frame} eq 'set')) { delete $s->{-pcmd}->{-frame}; $s->output('' , $s->cgi->header(-charset => $s->charset() ,-type => 'text/html') ,'{-lang} ? ' lang="' .$s->lang(0,'-lang') .'"' : '') .">\n\n" ,'' ,$s->{-title} ||$s->cgi->server_name() ,"\n" ,'' ."\n" ,'',"\n" ,'',"\n" ,'',"\n" ,'',"\n" ,'',"\n" ,'',"\n"); return($s); } if (($on =~/\.psp$/i) # Perlscript file immediate && ($oa =~/^(?:frmCall|recForm|recList)$/)) { return(&{$s->{-die}}($s->lng(0,'cgiRun') .": Operation object '$on' illegal" .$s->{-ermd}) && undef) if $on =~/[\\\/]\.+[\\\/]/; my $f =$0 =~/^(.+[\\\/])[^\\\/]+$/ ? $1 .$on : $on; $s->psEval('-', $f, undef, $on, $om, $s->{-pcmd}, $s->{-pdta}); $s->end(); return($s); } # Wikiname if ($s->{-pcmd}->{-wikn}) { my $v =$s->recWikn($s->{-pcmd}->{-wikn}); if ($v) { $s->{-pcmd}->{-key} =$v->{-key}; $s->{-pcmd}->{-form} =$v->{-table}; $s->{-pcmd}->{-table} =$v->{-table}; $on =$s->{-pcmd}->{-form} if $s->{-pcmd}->{-form}; } } # Encoded form / table if ((!$s->{-pcmd}->{-form} || ($s->{-pcmd}->{-form} eq 'default')) && ($s->{-pcmd}->{-key} || $s->{-pdta})) { $s->rmlKey($s->{-pcmd}, $s->{-pdta}); $on =$s->{-pcmd}->{-form} if $s->{-pcmd}->{-form}; } # Determine / Delegate operation object requested / Execute while (1) { if ($s->{-form} && $s->{-form}->{$on}) {$oc ='f'; $om =$s->{-form}->{$on}} elsif ($s->{-table} && $s->mdeTable($on)) {$oc ='t'; $om =$s->mdeTable($on)} else {$oc ='' ; $om =undef} return(&{$s->{-die}}($s->lng(0,'cgiRun') .": Operation object '$on' not found" .$s->{-ermd}) && undef) if !$om; $s->{-pcmd}->{-table} =($oc eq 't' ? $on : $om->{-table}); # translation trigger &{$s->{-cgiRun0A}}($s,$s->{-pcmd}) if $s->{-cgiRun0A}; &{$s->{-table}->{$s->{-pcmd}->{-table}}->{-cgiRun0A}}($s,$s->{-pcmd}) if $s->{-table} && $s->{-pcmd}->{-table} && $s->mdeTable($s->{-pcmd}->{-table}) && $s->{-table}->{$s->{-pcmd}->{-table}}->{-cgiRun0A}; &{$om->{-cgiRun0A}}($s,$s->{-pcmd}) if $om && $om->{-cgiRun0A}; # redirectional implemtation: '-cgcURL' foreach my $e (map {$om->{$_}} ('-cgcURL', '-redirect')) { next if !defined($e); last if !$e; last if $oa eq 'frmHelp'; print $s->cgi->redirect(-uri=>$e, -nph=>(($ENV{SERVER_SOFTWARE}||'') =~/IIS/) ||($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER})); $s->end(); return($r); } # external implemtation: '-cgcXXX' foreach my $e (map {$om->{"-cgc$_"}} $oa =~/^rec(.+)/ ? $1 : $oa ,$og =~/^rec(.+)/ ? $1 : $og, 'Call') { next if !defined($e); last if !$e; last if $oa eq 'frmHelp'; $s->cgibus(1); $s->{-pcmd}->{-form} =$on if !ref($e); $e =$` .$e if !ref($e) && !-f $e && ($0=~/[^\\\/]+$/); $_ =$s; $r = ref($e) ? &$e($s, $on, $om, $s->{-pcmd}, $s->{-pdta}) : $e =~/\.psp$/i ? $s->psEval('-', $e, undef, $on, $om, $s->{-pcmd}, $s->{-pdta}) : do($e); $s->end(); return($r) } my $nxt; # delegation - substitute object foreach my $v (map {$om->{"-$_"}} 'subst', $oa , $og =~/rec(New|Read|Del|QBF)/ ? ($og, 'recForm') : $og) { next if !defined($v) || ref($v); last if !$v; $on = $nxt =$v; last } $on =$nxt =$s->{-pcmd}->{-form} =$om->{-table} if !$nxt && ($og eq 'recNew') && ($oc eq 'f') && !exists($om->{-recNew}) && !exists($om->{-recForm}) && !$om->{-field} && $om->{-table} && $s->mdeTable($om->{-table}) && !$s->{-table}->{$om->{-table}}->{-ixcnd}; next if $nxt; last; } # Execute action $s->cgibus(1); if (ref(my $e =$om->{"-$oa"}) eq 'CODE') { $s->{-pout} =&$e($s, $on, $om, $s->{-pcmd}, $s->{-pdta}); } else { $s->{-pout} =$s->cgiAction($on, $om, $s->{-pcmd}, $s->{-pdta}); } # Reassign form if changed $s->{-pcmd}->{-form} =(isa($s->{-pout}, 'HASH') && $s->{-pout}->{-form}) || $s->{-pcmd}->{-form} ||$on; # Execute external presentation '-cgvXXX' foreach my $e (map {$om->{"-cgv$_"}} $oa =~/^rec(.+)/ ? $1 : $oa ,$og =~/^rec(.+)/ ? $1 : $og, 'Call') { next if !defined($e); last if !$e; last if $oa eq 'frmHelp'; $_ =$s; $r = ref($e) ? &$e($s, $on, $om, $s->{-pcmd}, $s->{-pout}) : $e =~/\.psp$/i ? $s->psEval('-', $e, undef, $on, $om, $s->{-pcmd}, $s->{-pout}) : do($e); $s->end(); return($r); } # Execute predefined presentation implementation $s->output( $s->htmlStart($s->{-pcmd}->{-form}, $om) # HTTP/HTML/Form headers ,$s->htmlHidden($s->{-pcmd}->{-form}, $om) # common hidden fields ,$s->htmlMenu($on, $om) # Menu bar ); $s->cgiForm($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('recFormRWQ'); $s->cgiList($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('recList'); $s->cgiHelp($on, $om, $s->{-pcmd}, $s->{-pout}) if $s->cgiHook('frmHelp'); $s->recCommit(); $s->cgiFooter(); $s->output($s->htmlEnd()); $s->end(); cgiRunEND: $s } sub cgiParse { # Parse CGI call parameters my ($s) =@_; my $g =$s->cgi; my $d =$g->Vars; $s->{-pcmd} ={}; $s->{-pdta} ={}; $s->{-lng} =$g->http('Accept_language')||''; $s->set(-lng =>lc($s->{-lng} =~/^([^ ;,]+)/ ? $1 : $s->{-lng})); foreach my $k (keys %$d) { next if !defined($d->{$k} || $d->{$k} eq ''); if($k =~/^_(quname)__S$/) { # cgiDDLB choise $s->{-pcmd}->{"-$1"} =$d->{'_' .$1 .'__L'}; $s->{-pdta}->{$k} =$d->{$k}; $d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm'; } elsif($k =~/^(.+)__S$/) { # cgiDDLB choise $s->{-pdta}->{$1} =$d->{$1 .'__L'}; $s->{-pdta}->{$k} =$d->{$k}; $d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm'; } elsif($k =~/^(.+)__R$/) { # cgiDDLB reset $s->{-pdta}->{$1} =undef; $s->{-pdta}->{$1 .'__S'} =$d->{$k}; $d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm'; } elsif($k =~/^(.+)__O$/) { # cgiDDLB open $s->{-pdta}->{$k} =$d->{$k}; $d->{_cmd} =$s->{-pcmd}->{-cmd} ='recForm'; } elsif($k =~/^_(new|file)$/) { # record attribute $s->{-pdta}->{"-$k"} =$d->{$k} } elsif ($k =~/^_(cmd|cmg|frmCall|frmName\d*|frmLso|frmLsc|frmHelp|recNew|recRead|recPrint|recXML|recHist|recEdit|recIns|recUpd|recDel|recForm|recList|recQBF|submit.*|app.*|form|key|wikn|proto|urm|qjoin|qkey|qwhere|qurole|quname|qftext|qversion|qorder|qkeyord|qlist|qlimit|qdisplay|qftwhere|qftord|qftlimit|edit|backc|login|print|xml|hist|refresh|style|frame|search)(?:\.[xXyY]){0,1}$/i) { my ($c, $v) =($1, $d->{$k}); # command $v =$1 if ($k !~/^_(key|proto|qkey|qftext)/i) && ($v =~/^\s*(.+?)\s*$/); if ($k =~/^(.+)\.[xXyY]$/) { $g->param($1, 1); $g->delete($k); $v=1; } if ($c =~/^(?:rec|frmCall|frmHelp|submit)/i) { $s->{-pcmd}->{-cmd} =$c } elsif (($c eq 'frmLso') && ($v =~/,/)) { $s->{-pcmd}->{"-$c"}=[split /\s*,\s*/, $v]; } else { $s->{-pcmd}->{"-$c"}=$v } } else { # data $s->{-pdta}->{$k} =$d->{$k} } } my $c =$s->{-pcmd}; $c->{-cmg} ='recList' if !$c->{-cmg} && !$c->{-cmd}; $c->{-cmd} =!$c->{-cmg}? 'frmCall' : $c->{-cmg} eq 'recList' ? 'recList' : 'recForm' if !$c->{-cmd}; $c->{-cmg} =$c->{-cmd} eq 'recForm' ? 'recList' : $c->{-cmd} if !$c->{-cmg}; map {$c->{$_} =datastr($s, $c->{$_}) } grep {$c->{$_}} qw(-key -qkey -proto); $c->{-key} =$s->rmlKey($c, $s->{-pdta}) if $c->{-key} && !ref($c->{-key}) && $s->{-idsplit}; $c->{-form}=$c->{-table} if !$c->{-form} && $c->{-table}; if ($c->{-frmLso} && $c->{-frmLso} eq 'recQBF') { $c->{-cmd} =$c->{-frmLso}; delete $c->{-frmLso}; $g->delete('_frmLso'); } if ($c->{-cmd} eq 'frmCall') { my $frm =($c->{-frmName1} ||$c->{-frmName} ||$c->{-form} ||'default'); if ($frm eq '-frame=set') { $c->{-frame} ='set'; $c->{-form} =$c->{-form} ||'default'; } else { $c->{-cmd} =$c->{-cmg} =($frm =~/[+]+\s*$/ ? 'recNew' : $frm =~/[&.^]+\s*$/ ? 'recForm' : 'recList'); $frm =($frm=~/^(.+)(?:\s*[+&.^]+\s*)$/ ? $1 : $frm); if ($frm ne ($c->{-form}||'')) { # !!! query parameters for current view only, not table map {delete $c->{$_} } qw (-frmLso -frmLsc -qjoin -qkey -qwhere -qurole -quname -qversion -qorder -qkeyord); $g->delete('_frmLso'); delete $c->{-key} if ($c->{-cmd} eq 'recList') || ($c->{-cmg} eq 'recList'); $c->{-backc} =0; } $c->{-form} =$frm; } } if ($c->{-cmd} eq 'recNew') { $c->{-edit} =1; $c->{-backc}=0; } elsif ($c->{-cmd} eq 'recEdit') { $c->{-edit} =1; $c->{-cmd} ='recRead' } elsif ($c->{-cmd} eq 'recQBFReset') { foreach my $k (qw(-qjoin -qkey -qwhere -qurole -quname -frmLso -frmLsc)) { delete $c->{$k}; } $c->{-cmd} ='recList'; $c->{-cmg} ='recList'; $c->{-form} =$c->{-qlist} || $c->{-form}; $c->{-backc}=0; } elsif ($c->{-cmd} eq 'recPrint') { $c->{-print} =1; $c->{-cmd} ='recRead' } elsif ($c->{-cmd} eq 'recXML') { $c->{-xml} =1; $c->{-cmd} =$c->{-cmg} ||'recRead'; $c->{-cmd} ='recList' if $c->{-cmd} =~/^(?:recXML|recQBF)$/; } elsif ($c->{-cmd} eq 'recHist') { $c->{-hist} =1; $c->{-cmd} ='recRead'; # $c->{-backc}=0; } elsif ($c->{-cmd} eq 'frmHelp') { $c->{-edit} =undef; $c->{-backc}=0 if ($c->{-cmg} ne $c->{-cmd}); } elsif ($c->{-cmd} !~/^(recIns|recUpd|recForm)/) { $c->{-edit} =undef } if ($c->{-cmd} =~/recList/ and $c->{-key}) { $c->{-qkey} =$c->{-key}; delete $c->{-key}; } if ($c->{-cmd} =~/recList/ and $c->{-cmg} =~/recQBF/) { $c->{-qkey} =$s->cgiQKey($c->{-form}, undef, $s->{-pdta}); $c->{-qkey} ='' if !%{$c->{-qkey}}; foreach my $k (qw(-frmLso -frmLsc)) {delete $c->{$k} if !$c->{$k}}; $c->{-form} =$c->{-qlist} || $c->{-form}; $c->{-backc}=0; } elsif ($c->{-cmd} =~/recQBF/ && $c->{-cmg} =~/recList/) { $c->{-edit} =1; $s->{-pdta} ={}; map { $s->{-pdta}->{$_} =$c->{-qkey}->{$_} if defined($c->{-qkey}->{$_}) && $c->{-qkey}->{$_} ne '' } keys %{$c->{-qkey}} if ref($c->{-qkey}); $c->{-qlist}=$c->{-form}; $c->{-backc}=0; } if ($c->{-cmd} !~/recList/) { delete $c->{-refresh}; } $c->{-backc} =( ($c->{-cmd} eq 'recForm') || ($c->{-cmd} eq 'recIns') || ($c->{-cmd} eq 'frmHelp') || (($c->{-cmd} eq 'recRead') || ($c->{-cmg} eq 'recRead')) || (($c->{-cmd} eq 'recList') || ($c->{-cmg} eq 'recList')) ? ($c->{-backc}||0) +1 : 1); $c->{-cmh} =$c->{-cmg}; # history general command $c->{-cmg} =$s->cgiHook('cmgNext'); # actual general command $s } sub cgiHook { # HTML generation hook condition $_[0]->cgiParse() if !$_[0]->{-pcmd}->{-cmd}; my $c =$_[0]->{-pcmd}; return($c->{-cmd}) if !$_[1]; ($_[1] eq $c->{-cmd}) # current operation ? $c->{-cmd} : ($_[1] eq 'recOp') # record operation (exept 'recList') && ($c->{-cmd} =~/^rec(New|Form|Read|Edit|Ins|Upd|Del)/) ? $c->{-cmd} : ($_[1] eq 'cmgNext') # next global command to output as hidden ? ( $c->{-cmd} eq 'recForm' ? $c->{-cmg} : (grep {$c->{-cmd} eq $_} qw(recIns recUpd)) ? 'recRead' : $c->{-cmd} eq 'recDel' ? $c->{-cmd} : $c->{-cmd}) : ($_[1] =~/^recForm/) # generate HTML form of record &&($c->{-cmd} !~/app|Help/) &&( $_[1] !~/^recForm([RWDQL]+)/ ||($_[1] =~/[WR]/ && $c->{-cmg} =~/^rec(Form|Read)/) ||($_[1] =~/[W]/ && $c->{-cmg} =~/^rec(New|Form|Read|Ins|Upd)/) ||($_[1] =~/[D]/ && $c->{-cmg} =~/^rec(Del)/) ||($_[1] =~/[Q]/ && $c->{-cmg} eq 'recQBF') ||($_[1] =~/[L]/ && $c->{-cmg} eq 'recList') ) ? $c->{-cmd} : ($_[1] eq 'recList') # generate HTML list of records && ($c->{-cmd} eq 'recList') ? $c->{-cmd} : ($_[1] eq 'recCommit') # commit database operation && ($c->{-cmd} =~/^rec(New|Form|Read|Ins|Upd|Del|List)/) ? $c->{-cmd} : '' } sub urlAuth { # Login URL my $s =$_[0]; my $u =$s->{-login}; if ($u =~/\/$/) { my $u0=$u; my $u1=$s->cgi->self_url; #url(-absolute=>1); $u1=($u1=~/^\w+:\/\/[^\/]+(.+)/ ? $1 : $u1); my $i; while (($i =index($u0, '/')) >=0 and substr($u0,0,$i) eq substr($u1,0,$i)) { $u0 =substr($u0, $i+1); $u1 =substr($u1, $i+1); } $u .=$u1 } $u } sub urlOptl { # Option URL arg list my $s =$_[0]; my %v =(); my $l =0; my $m =800; # query length limit, was 100 # MSDN: METHOD Attribute | method Property: # the URL cannot be longer than 2048 bytes for (my $i =1; $i <$#_; $i+=2) { next if !defined($_[$i+1]) ||($_[$i+1] eq ''); $v{$_[$i] =~/^-/ ? '_' .substr($_[$i],1) : $_[$i]} =ref($_[$i+1]) ? $s->strdata($_[$i+1]) : $_[$i+1]; }; if ($v{'_all'}) {$m =0; delete $v{'_all'}}; foreach my $k (keys %v) {$l +=length($k) +length($v{$k}||0)}; ((map { my $n =$_; my $v; if ( defined($s->{-pcmd}->{$_}) && ($s->{-pcmd}->{$_} ne '') && ($n =$_ =~/^-/ ? '_' .substr($_,1) : $_) && ($n !~/_(?:frmName|cmg|cmh|cmdf|cmdt|backc|ui)/i) && !exists($v{$n}) ) { $v =ref($s->{-pcmd}->{$_}) ? $s->strdata($s->{-pcmd}->{$_}) : $s->{-pcmd}->{$_}; $l +=length($n) +length($v); $v =undef if $m && ($l >$m); } defined($v) ? ($n => $v) : () } sort keys %{$s->{-pcmd}}), %v) } sub urlOpt { # Option URL $_[0]->urlCat($_[0]->url, $_[0]->urlOptl(@_[1..$#_])) } sub psParse { # PerlScript Parse Source my $s =shift; # (?options, perl script source, base URL) my $opt=substr($_[0],0,1) eq '-' ? shift : '-'; my $i =$_[0]; # input source my $b =$_[1]; # base URL my $o =''; # output source my ($ol,$or) =('',''); my ($ts,$tl,$ta,$tc) =('','','',''); if ($i =~/<(!DOCTYPE|html|head)/i && $`) { $i ='<' .$1 .$' } if ($b && $i =~m{(]*>)}i) { my ($i0,$i1) =($` .$1 ,$'); $i =$i0 .('') .$i1 } if ($opt =~/e/i && $i =~m{]*>}i) { # '-e'mbeddable html $i =$'; $i =$` if $i =~m{}i } while ($i) { if (not $i =~/<(\%@|\%|script)\s*(language\s*=\s*|)*\s*(PerlScript|Perl|)*\s*(runat\s*=\s*Server|)*[\s>]*/i) { $ol =$i; $i =''; $ts =''; } elsif (($2 && !$3) || (!$3 && $tl eq '1')) { $ol =$` .$&; $i =$'; $tl =1; $tc =$ts =''; } elsif ($1) { $ol =$`; $i =$'; $ts =uc($1||''); $tl =($2 && $3)||''; $ta=$4||''; if ($i =~/\s*(\%>|<\/script\s*>)/i) {$tc =$`; $i =$'} else {$tc =''} } else { $ol =$i; $i =''; } $ol =~s/(["\$\@%\\])/\\$1/g; $ol =~s/[\n]/\\n");\n\$_[0]->output("/g; $o .= "\$_[0]->output(\"$ol\\n\");\n"; next if !$ts || !$tc || $ts eq '%@'; $tc =~s/\<?//g; $tc =~s/\&?/\&/g; $tc =~s/\"?/"/g; if ($ts eq '%') { $o .= "\$_[0]->output($tc);\n" } elsif ($ts eq 'SCRIPT') { $o .= $tc .";\n"} } $o; } sub psEval { # Evaluate perl script file my $s =shift; # (?options, filename, ?base URL,...) my $o =substr($_[0],0,1) eq '-' ? shift : '-'; my $f =shift; # filename my $u =shift; # base URL my $c =undef; # code if ($f !~/^(\/|\w:[\\\/])/ && !-e $f) { $f =$s->{-path} .'/psp/' .$f; $u =$s->{-url} if !$u; } my $h =$s->hfNew($f); $h->read($c, -s $f); $h->close(); $s->output($s->{-c}->{-httpheader} =$s->cgi->header( -charset => $s->charset(), -expires => 'now' , ref($s->{-httpheader}) ? %{$s->{-httpheader}} : ())) if $o !~/e/; # '-e'mbeddable html local $SELF =$s; $c =eval('sub{' .$s->psParse($o, $c, $u, @_) .'}'); return(&{$s->{-die} }("psParse($o, $f)->$@" .$s->{-ermd}) && undef) if !$c; local $_ =$s; eval{&$c($s, $o, $f, @_)}; return(&{$s->{-die} }("psEval($o, $f)->$@" .$s->{-ermd}) && undef) if $@; $s } sub cgiAction { # cgiRun Action Executor encapsulated # self, obj name, ?obj meta, ?command, ?data my ($s, $on, $om, $oc, $od) =@_; $om =$s->{-form}->{$on}||$s->mdeTable($on) if !$om; $oc =$s->{-pcmd} if !$oc; $od =$s->{-pdta} if !$od; my $oa =$s->{-pcmd}->{-cmd}; my $og =$oc->{-cmg}; if ($oc->{-table} && $oa =~/^rec/) { if ($oa =~/^recList/) { $s->{-pout} =$s->cgiQuery($on, $om) } elsif ($oa =~/^recQBF/ ||$og =~/^rec(?:List|QBF)/) { $s->{-pout} ={%{$od}}; } elsif ($oa =~/^rec(?:Read)/) { $s->rmiTrigger($oc, $od, undef, qw(-recTrim0A -recForm0A)); $s->{-pout} =$s->recRead( (map {($_=>$oc->{$_}) } grep {defined($oc->{$_}) && $oc->{$_} ne '' } qw(-table -key -wikn -form -edit -ui)) , ref($om->{-recRead}) eq 'HASH' ? %{$om->{-recRead}} : ()); } else { $s->rmiTrigger($oc, $od, undef, qw(-recTrim0A)) if $oa =~/^rec(?:New|Form|Ins|Upd|Del)/; $s->rmiTrigger($oc, $od, undef, qw(-recForm0A -recEdt0A)) # uncleaned data may be needed for -recEdt0A if $oa =~/^rec(?:Form|Ins|Upd|Del)/; $od =$s->cgiDBData($on, $om, $oc, $od); $s->{-pout} =$s->$oa(-data=>$od , $oa =~/^rec(?:Upd|Del)/ ? (-version =>'+') : () ,(map {($_=>$oc->{$_}) } grep {defined($oc->{$_}) && $oc->{$_} ne '' } qw(-table -form -edit -ui -key -proto))); } $oc->{-key} =$s->recKey($oc->{-table}, $s->{-pout}) if $oa =~/^rec(?:Read)/ && !$oc->{-edit}; $oc->{-key} =$s->recWKey($oc->{-table}, $s->{-pout}) if $oa =~/^rec(?:Read|Ins|Upd)/ && $oc->{-edit}; delete $oc->{-key} if $oa =~/^rec(?:New)/; delete $oc->{-edit} if $oc->{-edit} && $oa =~/^rec(?:Ins|Upd|Del)/; $s->{-pout} =$s->recRead( (map {($_=>$oc->{$_}) } grep {defined($oc->{$_}) && $oc->{$_} ne '' } qw(-table -key -form -ui)) , %{$om->{-recRead}}) if ref($om->{-recRead}) eq 'HASH' && $oa =~/^rec(?:Ins|Upd)/; $s->rmiTrigger($oc, $s->{-pout}, undef, qw(-recForm0A -recEdt0A)) if $oc->{-edit} && ($oa =~/^rec(?:Read|New)/); $s->rmiTrigger($oc, $s->{-pout}, undef, qw(-recEdt1A)) if $oa =~/^rec(?:Ins|Upd)/; $s->rmiTrigger($oc, $s->{-pout}, undef, qw(-recForm1A)) if $oa =~/^rec(?:New|Form|Ins|Upd|Read)/; } elsif ($oa =~/^(recForm|frmHelp)/) { # nothing needed } else { return(&{$s->{-die}}($s->lng(0,'cgiRun') .": Action '$oa\@$og' not found" .$s->{-ermd}) && undef) } $s->{-pout} } sub htmlStart { # HTTP/HTML/Form headers my ($s,$on,$om)=@_; # (object name, object meta) $on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||'default' if !$on; my $cs = $s->{-c}->{-htmlclass} = $s->{-pcmd}->{-xml} ? undef : ref($s->{-htmlstart}) && $s->{-htmlstart}->{-class} ? $s->{-htmlstart}->{-class} : $s->cgiHook('recOp') ? 'Form' .($on ? ' ' .$on : '') : $s->cgiHook('recFormQ') ? 'Form' .($on ? ' ' .$on : '') .' QBF' .($on ? ' ' .$on .'__QBF' : '') : $s->cgiHook('frmHelp') ? 'Form Help' .($on ? ' ' .$on .'__Help' : '') : 'Form' .($on ? ' ' .$on : '') .' List' .($on ? ' ' .$on .'__List' : ''); my $r =join("" , $s->{-c}->{-httpheader} ? () : do{$s->{-c}->{-httpheader} =$s->cgi->header( -charset => $s->charset(), -expires => 'now' , ref($s->{-httpheader}) ? %{$s->{-httpheader}} : () , $s->{-pcmd}->{-xml} ? (-type => 'text/xml') : () )} , $s->{-c}->{-htmlstart} = $s->{-pcmd}->{-xml} ? (ref($s->{-xmlstart}) ? $s->xmlsTag($s->{-xmlstart}) : ($s->{-xmlstart} ||('{-charset} ? '' : ' encoding="' .$s->charset() .'"') .' ?>')) .($s->{-pcmd}->{-style} ? '{-pcmd}->{-style} .'" type="text/css" ?>' : '') ) : $s->cgi->start_html( -head => '' .($s->{-pcmd}->{-refresh} ? '' : '') ,-lang => $s->lang(0,'-lang') ,-encoding => $s->charset() ,-style => {-code=>'' .".Body {font-size: 70%; font-family: Verdana, Helvetica, Arial, sans-serif; }\n" .".Input {font-size: 100%; font-family: Verdana, Helvetica, Arial, sans-serif; }\n" .".Form {margin-top:0px; }\n" ."td.Form {border-style: none; border-width: 0px; padding: 0px;}\n" ."th.Form {border-style: none; border-width: 0px; padding: 0px;}\n" ."table.ListTable {border-collapse: collapse; }\n" ."th.ListTable {border-style: inset; border-color: buttonface; border-width: 0px; border-bottom-width: 1px; }\n" ."td.ListTable {border-style: inset; border-color: buttonface; border-width: 0px; border-bottom-width: 1px; padding: 0px; padding-left: 2px; padding-right: 1px; padding-top: 2px;}\n" .".ListTableFocus {background-color: buttonface;}\n" #.".MenuArea {background-color: navy; color: white;}\n" .".MenuButton {background-color: buttonface; color: black; text-decoration:none; font-size: 7pt}\n" .".MenuInput {font-size: 8pt}\n" .".htmlMQHsel {text-decoration: none; font-weight: bolder; border-style: inset;}\n" } ,-title => (do{ my $v =($s->{-pcmd} && $s->{-pcmd}->{-cmd} ||'') eq 'frmHelp' ? $s->lng(0,'frmHelp') : (eval{$om && $s->lnglbl($om)}); $v ? $v .' - ' : ''}) .($s->{-title} ||$s->cgi->server_name()) ,-class => "Body $cs" ,$s->{-pcmd}->{-frame} ? (-target=>$s->{-pcmd}->{-frame}) : (-target=>'_self') ,ref($s->{-htmlstart}) ? %{$s->{-htmlstart}} : () ,$s->{-pcmd}->{-style} ? (-style=>{'src'=>$s->{-pcmd}->{-style}}) : ()) , "\n" , $s->{-pcmd}->{-xml} ? $s->xmlsTag($s->{-pcmd}->{-form}||'default' , (map { defined($s->{-pcmd}->{$_}) && ($s->{-pcmd}->{$_} ne '') ? ((substr($_,0,1) eq '-' ? substr($_,1) : $_) ,$s->{-pcmd}->{$_}) : () } sort keys %{$s->{-pcmd}}) , 'xmlns'=>$s->url , '0') : $s->cgi->start_multipart_form(-method=>($s->{-pcmd}->{-refresh} ? 'get' : 'post') ,-class => "$cs" ,-action=> $s->url ,-target=> '_self' ,-name=>'DBIx_Web' # !!! 'DBIx_Web.' or 'forms[0].' syntax inflexible ) ) ."\n"; eval{warningsToBrowser(1)} if *warningsToBrowser{CODE}; $r; } sub htmlEnd { # End of HTML/HTTP output my ($s) =@_; if ($s->{-pcmd}->{-xml}) { return("\nxmlTagEscape($s->{-pcmd}->{-form}||'default') .">\n") } else { return($s->cgi->endform() ,"\n" ,$s->htmlOnLoadW( (!$s->{-c}->{-jswload} || !(grep {($_=~/\.target/) && ($_=~/'BASE'/)} @{$s->{-c}->{-jswload}}) ? "{var e=document.getElementsByTagName('BASE'); if(e && e[0] && (e[0].target=='_self')){e[0].target=(self.name=='BOTTOM' ? 'TOP1' : self.name=='TOP' ? 'BOTTOM'" .($s->{-pcmd}->{-frame} ? " : self.name=='" .$s->{-pcmd}->{-frame} ."' ? 'TOP1'" ." : self.name!='" .$s->{-pcmd}->{-frame} ."' ? '" .$s->{-pcmd}->{-frame} ."'" : '') ." : e[0].target)}}" : ()) ,($s->{-pcmd}->{-search} && $s->{-c}->{-search} ? ("{window.document.open('" .($s->{-c}->{-search} =~/^\?/ ? $s->url() .$s->{-c}->{-search} : $s->{-c}->{-search}) ."','_search','',true)}") : ()) ) ,$s->cgi->end_html()) } } sub htmlOnLoad {# OnLoad event JavaScript store $_[0]->{-c}->{-jswload} =[] if !$_[0]->{-c}->{-jswload}; push @{$_[0]->{-c}->{-jswload}}, @_[1..$#_]; '' } sub htmlOnLoadW {# OnLoad event JavaScript write $_[0]->htmlOnLoad(@_[1..$#_]) if $#_; return() if !$_[0]->{-c}->{-jswload}; my $v ="\n"; delete $_[0]->{-c}->{-jswload}; $v } sub htmlHidden {# Common hidden fields my ($s, $on, $om) =@_; return('') if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print}; $on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||'' if !$on; join("\n" ,'' ,'' ,'' ,(map { !defined($s->{-pcmd}->{"-$_"}) || (($s->{-pcmd}->{"-$_"} eq '') && ($_ !~/^(?:qkey|qwhere|qurole)$/)) ? () : ('{-pcmd}->{"-$_"}) ? strdata($s, $s->{-pcmd}->{"-$_"}) : $s->{-pcmd}->{"-$_"}) .'" />') } qw(edit backc key style frame) ,($s->{-pcmd}->{-cmg} ne 'recQBF' ? qw(qkey qjoin qwhere qurole quname qversion qorder qkeyord qlimit qdisplay) : qw(qlist)) ) ) ."\n" } sub htmlMenu { # Screen menu bar my ($s,$on,$om) =@_; return('') if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print}; $on =$s->{-pcmd}->{-form} ||$s->{-pcmd}->{-table} ||'' if !$on; $om =$on && $s->{-form}->{$on}||$s->mdeTable($on) if !$om; my $ot=$om && $om->{-table} && $s->mdeTable($om->{-table}) || $om; my $c =$s->{-pcmd}; my $a =$c->{-cmd} ||''; my $g =$c->{-cmg} ||''; my $e =$c->{-edit}; my $d =$s->{-pdta}; my $n =$d->{-new} ||($c->{-cmg} eq 'recNew'); my $cs=join(' ' ,$s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) : () ,'MenuArea'); local $c->{-cmdt} =$ot || $om; # table metadata local $c->{-cmdf} =$om || $ot; # form metadata my @r =(); if ($s->{-logo}) { # Logotype push @r, htmlMB($s, 'logo'); } elsif ($s->{-icons}) { # Home push @r, htmlMB($s, $s->{-c}->{-search} ? 'schpane' : 'home'); } if (1) { # 'back' js button push @r, htmlMB($s, 'back' , $g ne 'recList' ? $s->urlCmd('',-form=>$on, -cmd=>'recList', $c->{-frame} ? (-frame=>$c->{-frame}) : ()) : $s->urlCmd('',$c->{-frame} ? (-frame=>$c->{-frame}) : ()) , ($c->{-backc}||1)); } if ($s->uguest() && $s->{-login}) { # Login push @r,htmlMB($s, 'login', $s->urlAuth()); } if ($g eq 'recList') { # View menu items local @{$s}{-menuchs, -menuchs1} =@{$s}{-menuchs, -menuchs1}; $s->htmlMChs() if !$s->{-menuchs}; # push @r, htmlMB($s, 'recForm'); push @r, htmlML($s, 'frmName', $s->{-menuchs} , !$c->{-frame} || ($c->{-frame} =~/^(?:TOP|BOTTOM)$/) ? '-frame=set' : () ) if $s->{-menuchs}; push @r, htmlML($s, 'frmLso' , ref($om->{-frmLso}) eq 'CODE' ? &{$om->{-frmLso}}($s, $on, $om, $c, exists($c->{-frmLso}) ? $c->{-frmLso} ||'' : ()) : $om->{-frmLso} ) if $om->{-frmLso}; push @r, htmlMB($s, htmlField($s, '_qftext', lng($s,1,'-qftext'), {-asize=>5, -class=>'Input ' .$cs .' MenuInput'}, $s->{-pcmd}->{-qftext})) if $s->{-menuchs}; push @r, htmlML($s, 'frmName1', $s->{-menuchs1})if $s->{-menuchs1}; local $c->{-frame} =undef; push @r, htmlMB($s, 'frmCall', ['', $s->urlOptl(-cmd=>'frmCall')]) if $s->{-menuchs}; push @r, htmlMB($s, 'recXML', ['', $s->urlOptl(-cmd=>'frmCall',-xml=>1)]); push @r, htmlMB($s, 'recQBF'); if ($s->uguest) {} elsif ($om->{-recNew} || $om->{-recForm} || ($on && (grep {( !ref($_) ? $_ : ref($_) eq 'HASH' ? $_->{-val} : $_->[0]) =~/^\Q$on\E\+/ } @{$s->{-menuchs1} ||$s->{-menuchs} ||[]})) ) { push @r, htmlMB($s, 'recNew') } elsif ( $om->{-table} && !$om->{-field} && $s->{-table}->{$om->{-table}} && !$s->{-table}->{$om->{-table}}->{-ixcnd} && do{my $on =$om->{-table}; grep {( !ref($_) ? $_ : ref($_) eq 'HASH' ? $_->{-val} : $_->[0]) =~/^\Q$on\E\+/ } @{$s->{-menuchs1} ||$s->{-menuchs} ||[]}} ){ push @r, htmlMB($s, 'recNew') } } elsif ($g eq 'recQBF') { # QBF menu items push @r, htmlMB($s, 'recForm', ''); push @r, htmlMB($s, 'recQBFReset' ); push @r, htmlMB($s, 'recList', ''); push @r, htmlMB($s, 'recXML', ''); } elsif ($g eq 'recDel') { # Deleted record menu items } elsif ($s->cgiHook('recOp')) { # Record menu items my $ea =(!$s->{-rac} ||$s->{-pout}->{-editable}) &&!$s->uguest && ((ref($s->{-pout}->{-editable}) && $s->{-pout}->{-editable}->{-fr}) ||1); my @rk =('','_form'=>$_[0]->{-pcmd}->{-form}, '_key'=>strdata($_[0], $_[0]->{-pcmd}->{-key})); my $ll =$s->lnghash(); local $ll->{'recIns'} = $e && $n ? [$ll->{'recUpd'}->[0], $ll->{'recIns'}->[1]] : $ll->{'recIns'}; local $IMG->{'recIns'}= $e && $n ? $IMG->{'recUpd'} : $IMG->{'recIns'}; push @r, htmlMB($s, 'recRead', [@rk, '_cmd'=>'recRead']) if !$n; push @r, htmlMB($s, 'recPrint', [@rk, '_cmd'=>'recRead', '_print'=>1]) if !$n && !$e; push @r, htmlMB($s, 'recXML', [@rk, '_cmd'=>'recRead', '_xml'=>1]) if !$n && !$e; push @r, htmlMB($s, 'recHist', [@rk, '_cmd'=>'recRead', '_hist'=>1]) if !$n && !$e && ($ot->{-rvcActPtr} ||$s->{-rvcActPtr}); push @r, htmlMB($s, 'recEdit', [@rk, '_cmd'=>'recEdit']) if !$n && !$e && $ea; push @r, htmlMB($s, 'recForm', '') if $e; push @r, htmlMB($s, 'recUpd', '') if $e && !$n; push @r, htmlMB($s, 'recIns', '') if $e; push @r, htmlMB($s, 'recDel', '') if !$n && $ea && (!ref($ea) ||!$ea->{-recDel}); push @r, htmlMB($s, 'recNew' # ,undef) ,['','_cmd'=>'recNew','_form'=>$_[0]->{-pcmd}->{-form} , '_proto'=>strdata($_[0], $_[0]->{-pcmd}->{-key})]) if !$n && !$s->uguest; } if ($a ne 'frmHelp') { # Help button push @r, htmlMB($s, 'frmHelp'); } delete $c->{-htmlMQH}; my $mi ='[\'' .htmlEscape($s,lng($s, 0, $c->{-cmd})) .'\'@\'' .htmlEscape($s,lng($s, 0, $c->{-cmg})) .'\', ' .htmlEscape($s, $s->user()) .']'; my $mh =htmlEscape($s ,($a eq 'frmHelp' ? $s->lng(0, 'frmHelp') : $s->lngcmt($om, $ot)) || (($s->{-title} ||$s->cgi->server_name() ||'') .' - ' .($c->{-form} ||''))); my $mc =$g ne 'recList' ? '' : join("; " , grep {$_ } (defined($c->{-qkey}) ? $c->{-qkey} : ($om->{-query} && $om->{-query}->{-qkey})) ? do { my $kq =$c->{-qkey} ||($om->{-query} && $om->{-query}->{-qkey}); my $ko =$c->{-qkeyord} || ($c->{-qorder} && (substr($c->{-qorder},0,1) eq '-') && $c->{-qorder}) || '-aeq'; $ko ={'eq'=>'=','ge'=>'>=','gt'=>'>','le'=>'<=','lt'=>'<'}->{substr($ko,2)}||'='; $s->htmlEscape( join(', ', map { "$_ $ko " .dsdQuot($s," $ko ",$kq->{$_}) } sort keys %$kq)) } : () , ($c->{-qkeyord} ? htmlEscape($s, lng($s, 0, '-qkeyord') .' ' .lng($s, 0, $c->{-qkeyord} =~/^-*[db]/ ? 'desc' : 'asc')) : '') , (!$c->{-qwhere} ? '' : $c->{-qwhere} =~/^(?:\[\[\]\]|\/\*\*\/)+(.*)/ ? htmlEscape($s, $1) : htmlEscape($s, $c->{-qwhere})) , ($c->{-qjoin} ? htmlEscape($s, ($c->{-qjoin} =~/^\s*(?:CROSS|JOIN|INNER|STRAIGHT_JOIN|LEFT|NATURAL|RIGHT|OUTER)\b/i ? '' : (lng($s, 0, '-qjoin') .' ')) .$c->{-qjoin}) : '') , ($c->{-qurole} ? htmlEscape($s, lng($s, 0, '-qurole') .' ' .$c->{-qurole} .' /*' .$s->mddUrole($om, $c->{-qurole}) .'*/') : '') , ($c->{-quname} ? htmlEscape($s, lng($s, 0, '-quname') .' ' .$c->{-quname}) : '') , ($c->{-qftext} ? htmlEscape($s, lng($s, 0, '-qftext') .' ' .$c->{-qftext}) : '') , ($c->{-qversion}? htmlEscape($s, lng($s, 0, '-qversion') .' ' .$c->{-qversion}) : '') , ($c->{-qorder} ? htmlEscape($s, lng($s, 0, '-qorder') .' ' .($c->{-qorder} !~/^-/ ? $c->{-qorder} : lng($s, 0, $c->{-qorder} =~/^-[db]/ ? 'desc' : 'asc'))) : '') ); $mc = ($g eq 'recList') && ($om->{-frmLso1C} ||($ot->{-frmLso1C} && !exists($om->{-frmLso1C}))) ? &{$om->{-frmLso1C}||$ot->{-frmLso1C}}($s,$on,$om,$c,$mc) : $mc; ($s->{-banner} ? (do{ my $v =ref($s->{-banner}) ? &{$s->{-banner}}($s,$on,$om) : $s->{-banner}; $v ? "\n
$v
" : '' }) : '') .(!$s->{-icons} ? "\n
" .join("\n", @r, $mi, '
', $mh, '
', $mc ? ($mc, '
') : ()) ."
\n\n" : ("\n
\n" # cellspacing=\"1px\" # style=\"position: absolute; top: 0; left: 0;\" # scrolled up #

# scrollHeight .join("\n", @r) ."\n" .'' ."\n" ."
' . $mi .'
\n" # margin-top: 0px; margin-bottom: 0px; padding: 0px .'' .(!$mc ? '' : ("\n" .'')) ."\n
' .$mh .'
' .$mc .'
\n" .(!$c->{-refresh} ? $s->htmlOnLoad('{var w=window.document.getElementsByTagName(\'table\')[' .($e ? 1 : 0) .']; if(w){w.focus()}}') : '') .(0 # scrollTop==0 ? '' ."\n" : '') ."\n")) } sub htmlMB { # CGI menu bar button # self, command, url, back| my $cs =($_[0]->{-c}->{-htmlclass} ? $_[0]->htmlEscape($_[0]->{-c}->{-htmlclass}) .' ' : '') .'MenuArea MenuButton'; my $td0='{-icons}) { if ($_[1] =~/^{-logo}) eq 'CODE' ? &{$_[0]->{-logo}}(@_) : $_[0]->{-logo} } elsif ($_[1] eq 'login') { $_[1] } elsif ($_[1] eq 'back') { '' } else { '' } } elsif ($_[1] =~/^\n" .$_[1] ."\n" } elsif ($_[1] eq 'logo') { $_[0]->{-logo} ? $td0 .">\n" .( ref($_[0]->{-logo}) eq 'CODE' ? &{$_[0]->{-logo}}(@_) : $_[0]->{-logo}) ."\n" : htmlMB($_[0],'home') } elsif ($_[1] eq 'login') { my $jc =' onclick="{window.location.replace("' .htmlEscape($_[0], $_[2]) .'"); return(false)}" '; my $tl =htmlEscape($_[0], lng($_[0], 1, 'login')); $td0 .' title="' .$tl .'"' .($tdb ? $tdb .$jc : '') .">\n" .'' .htmlEscape($_[0], lng($_[0], 0, 'login')) ."\n" } elsif ($_[1] eq 'schpane') { my $pu =$_[0]->{-c}->{-search}; my $fr =$pu=~/\b_frame=RIGHT\b/; my $su =$fr ? $_[0]->urlOpt(-search=>1) : $_[0]->{-c}->{-search}; my $tl =htmlEscape($_[0], lng($_[0], 1, 'schpane')); $td0 .$tdb .' title="' .$tl .'"' .'>' ."\n" } elsif ($_[1] eq 'home') { my $jc =' onclick="{window.document.open(\'' .$_[0]->urlCat($_[0]->url,$_[0]->{-pcmd}->{-frame} ? ('_frame'=>$_[0]->{-pcmd}->{-frame}) : ()) ."','_self','',false); return(false)}\" "; my $tl =htmlEscape($_[0], lng($_[0], 1, 'home')); $td0 .($tdb ? $tdb .$jc : '') .' title="' .$tl .'"' .'>' ."\n" } elsif ($_[1] eq 'back') { my $jc =' onclick="{' .(!$_[3] ||$_[3] <2 ? 'window.history.back(); ' : ($ENV{HTTP_USER_AGENT}||'') =~/MSIE/ ?('window.history.go(-' .($_[3]-1) .'); window.history.back(); ') : 1 # !!! Non MSIE backwarding omission ?("window.document.open('" .htmlEscape($_[0],$_[2]) ."','_self','',false); ") :('window.history.back();' x $_[3]) ) .'return(false)}" '; my $jo =$jc =~/window\.document\.open/i; my $tl =htmlEscape($_[0], (!$jo ? '<-' .($_[3]||1) .'- ' : '') .lng($_[0], 1, 'back')); $td0 .' title="' .$tl .'"' .($tdb ? $tdb .$jc : '') .">\n" .'' ."\n" } else { my $hl =defined($_[2]) && !$_[2] ? undef : urlCat($_[0], !$_[2] ? ('', '_form'=>$_[0]->{-pcmd}->{-form},'_cmd'=>$_[1]) : ref($_[2]) ? @{$_[2]} : $_[2]); my $jc =' onclick="{' .($hl && ($_[1] =~/^(?:recRead|recPrint|recXML|recHist|recEdit|recNew|frmHelp)$/) ? "if((self.name=='BOTTOM') || (self.name=='TOP') ||document.getElementsByName('_frame').length){window.document.open('" .(($_[1] =~/^(?:recNew)$/ && ($hl =~/_proto=/)) ? (do {my $v=$hl; $v =~s/([?&;])_proto=/${1}_key=/; $v}) : $hl) ."','_blank','',false); return(false)}\n" : '') .'window.document.DBIx_Web._cmd.value="' .$_[1] .'"; window.document.DBIx_Web.submit(); return(false)}" '; my $tl =htmlEscape($_[0],lng($_[0], 1, $_[1])); $td0 .' title="' .$tl .'"' .($tdb ? $tdb .$jc : '') .">\n" .'' .(!$hl ?('' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'') .($tdb ? '' : $jc) :('' .htmlEscape($_[0],lng($_[0], 0, $_[1])) .'')) ."\n" } } sub htmlML { # CGI menu bar list use locale; # (self, name, values, ? add values) my $cs =join(' ' ,'Input' ,$_[0]->{-c}->{-htmlclass} ? $_[0]->htmlEscape($_[0]->{-c}->{-htmlclass}) : () ,'MenuArea'); my $i = $_[1] eq 'frmName' ? $_[0]->cgi->param('_' .$_[1]) ||$_[0]->{-pcmd}->{'-' .$_[1]} ||$_[0]->{-pcmd}->{-form} ||'' : $_[1] eq 'frmLso' ? (($_[0]->{-pcmd}->{'-' .$_[1]} ||'') eq '-all' ? '' : ($_[0]->{-pcmd}->{'-' .$_[1]} ||'')) : ''; my $li =$_[3]; my $f1 =undef; ($_[0]->{-icons} ? '' : '') .do{$cs .=' MenuInput'; ''} .'" .($_[0]->{-icons} ? '' : '') } sub htmlMChs { # Adjust CGI forms list if (!$_[0]->{-menuchs}) { $_[0]->{-menuchs} =[]; if ($_[0]->{-form}) { push @{$_[0]->{-menuchs}}, map {[$_, ($_[0]->lnglbl($_[0]->{-form}->{$_},$_)||$_)] } grep {($_ ne 'default') && ((ref($_[0]->{-form}->{$_}) ne 'HASH') || !$_[0]->{-form}->{$_}->{-hide}) } keys %{$_[0]->{-form}} } if ($_[0]->{-table}) { push @{$_[0]->{-menuchs}}, map {[$_, ($_[0]->lnglbl($_[0]->{-table}->{$_},$_)||$_)] } grep {(ref($_[0]->{-table}->{$_}) ne 'HASH') || !$_[0]->{-table}->{$_}->{-hide} } keys %{$_[0]->{-table}} } @{$_[0]->{-menuchs}} =sort {lc(ref($a) && $a->[1] || $a) cmp lc(ref($b) && $b->[1] || $b) } @{$_[0]->{-menuchs}}; if ($_[0]->{-menuchs} && !$_[0]->uguest()) { my @a =( ['','--- ' .lng($_[0], 0, 'frmCallNew') .' ---'] , map {[$_->[0] .'+', $_->[1] ] # .' ++' # also $f1 in htmlML() } grep { my $m; ($m =$_[0]->{-form}->{$_->[0]}) ? $m->{-field} : ($m =$_[0]->{-table}->{$_->[0]}) ? !$m->{-ixcnd} : 0 } @{$_[0]->{-menuchs}} ); if (@{$_[0]->{-menuchs}} <6) {push @{$_[0]->{-menuchs}}, @a} else {$_[0]->{-menuchs1} =[@a]} }} if ($_[0]->{-menuchs1} && (!ref($_[0]->{-menuchs1}->[0]) ? $_[0]->{-menuchs1}->[0] : ref($_[0]->{-menuchs1}->[0]) eq 'HASH' ? $_[0]->{-menuchs1}->[0]->{-val} : $_[0]->{-menuchs1}->[0]->[0])) { unshift @{$_[0]->{-menuchs1}}, ['', '--- ' .lng($_[0], 0, 'frmCallNew') .' ---'] } $_[0]->{-menuchs} } sub cgiDBData { # Database data fields/values # self, form, meta, value hash my ($s, $n, $m, $c, $v) =@_; $m =$s->{-form}->{$n}||$s->{-table}->{$n} if !$m; my $mt=$m->{-field}||($m->{-table} && $s->{-table}->{$m->{-table}}->{-field})||[]; my $mn=exists($m->{-null}) ? $m->{-null} : $m->{-table} ? $s->{-table}->{$m->{-table}}->{-null} : undef; my $cc=($c && $c->{-cmd} ||''); my @xx; my $r ={}; local $_; if (($c && $c->{-cmg} ||'') eq 'recNew') { $r->{-new} =$s->strtime; } foreach my $f (@$mt) { next if ref($f) ne 'HASH'; $r->{$f->{-fld}} =!defined($v->{$f->{-fld}}) ? $v->{$f->{-fld}} : exists($f->{-null}) ? (defined($f->{-null}) && ($v->{$f->{-fld}} eq $f->{-null}) ? undef : $v->{$f->{-fld}}) : defined($mn) ? ($v->{$f->{-fld}} eq $mn ? undef : $v->{$f->{-fld}}) : $v->{$f->{-fld}} if exists ($v->{$f->{-fld}}) && (!defined($f->{-flg}) || $f->{-flg} =~/[aeu]/); # 'a'll, 'e'dit, 'u'pdate if ($cc =~/^rec(?:Ins|Upd)/) { push @xx , ("'" .$s->lnglbl($f,'-fld') ."' - " .$s->lng(0,'fldReqStp')) if $f->{-flg} && ($f->{-flg} =~/[m]/) && (!defined($r->{$f->{-fld}}) || ($r->{$f->{-fld}} eq '')); if ($f->{-chk}) { $_ =$r->{$f->{-fld}}; $@ =''; &{$f->{-chk}}($s,$m,$f,$r); if ($@) {push @xx, ("'" .$s->lnglbl($f,'-fld') ."' - " .$@ .' - ' .$s->lng(0,'fldChkStp'))} else {$r->{$f->{-fld}} =$_} } } } return(&{$s->{-die}}($s->{-ermu} .join("\n",@xx). "\n\n") && undef) if scalar(@xx); %$r ? $r : undef } sub cgiForm { # Print CGI screen form # self, form name, form meta, command, data my ($s, $n, $m, $c, $d) =@_; $m =$s->{-form}->{$n}||$s->mdeTable($n) if !$m; $c =$s->{-pcmd} if !$c; $d =$s->{-pout} if !$d; return($s) if ($c->{-cmg}||'') eq 'recDel'; my $qm=($c->{-cmg}||'') eq 'recQBF'; my $em=$c->{-edit} || $qm; my $fm=($em || $qm ? 'e' : '') .($qm ? 'q' : '') .($c && $c->{-print} ? 'p' : ''); my $fr=ref($d) && ref($d->{-editable}) && $d->{-editable}->{-fr}; my $mt=$m->{-table} ? $s->mdeTable($m->{-table}) : $m; local $c->{-cmdt} =$mt || $m; # table metadata local $c->{-cmdf} =$m || $mt; # form metadata local $s->{-pout} =$s->{-pout}; my $lt =$c->{-xml} ? 1 : 0; # 1 - closed table, 2 - table & labels my $lr =1; # 1 - nxt row before my $hide =0; # 1 - field hidden, 2 - hidden left my $edit =0; # 1 - field editable if($qm) { $s->cgiQDflt($n, $m, $c); $d =$c->{-qkey} && {%{$c->{-qkey}}} || {} if (!$d ||!%$d); map { $d->{$_} =ref($d->{$_}) ? $s->dsdQuot($d->{$_}) : $d->{$_} } keys %$d; $c->{-frmLso} ='' if $c->{-frmLso} && ($c->{-frmLso} =~/^-/); } $s->output('' # cellspacing="0" cellpadding="0" # margin + left + border + padding ["Measuring Element Dimension and Location"] , $qm && $c->{-frmLso} ? ("\n\n" , '\n" , '\n\n" ) : () ,"\n\n") if !$c->{-xml}; # form additions - using sub{} fields # file attachments - using 'tfdRFD' / 'htmlRFD' # versions - using sub{} fields with queries # embedded views - using sub{} fields with queries foreach my $rhe ($c->{-hist} # history loop ? @{$s->recHist(-key=>$s->recKey($c->{-table}, $d) ,-table=>$c->{-table})} : $d) { next if !$rhe; if ($c->{-hist}) { $d =$s->{-pout} =$rhe->[3]; $s->output("\n" ,'\n" ,'\n" ,"\n"); } foreach my $v (@{$m->{-field} # field loop ||($m->{-query} && $m->{-query}->{-data}) ||($m->{-table} && $s->mdeTable($m->{-table})->{-field}) }) { my $f =(ref($v) && $v) || ($mt->{-mdefld} && $mt->{-mdefld}->{$v}) || $v; if ($c->{-xml}) { next if !ref($f); if (ref($f) eq 'CODE') {next} elsif ($f->{-inp} && $f->{-inp}->{-rfd} && $s->{-pout}->{-file}) { my $u =$s->rfdPath(-url=>$s->{-pcmd}, $s->{-pout}); $u =$s->url(-base=>1) .$u if $u !~/\/\/\w+:/; my $v =join("\n", map { $u .'/' .$_ } $s->rfdGlobn($s->{-pcmd}, $s->{-pout})); $s->output($s->xmlsTag('files',''=>$v),"\n"); next } elsif (!$f->{-fld} ||!defined($d->{$f->{-fld}}) ||($d->{$f->{-fld}} eq '')) {next} my $v =$d->{$f->{-fld}}; if ($f->{-inp} && $f->{-inp}->{-htmlopt} && $s->ishtml($v)) { $s->output('<',$f->{-fld},'>' ,$s->trURLhtm($v, sub{$_[1]} , sub{ $_[1] =~/^[\w-]{3,7}:\/{2}/ ? $_[1] : $_[1] =~/^\// ? $s->url(-base=>1) .$_[1] : $s->url .$_[1] }) ,'{-fld},">\n"); } elsif ($f->{-inp} && $f->{-inp}->{-hrefs}) { $v =$s->trURLtxt($v , sub{$_[1]} , sub{ $_[1] =~/^[\w-]{3,7}:\/{2}/ ? $_[1] : $_[1] =~/^\// ? $s->url(-base=>1) .$_[1] : $s->url .$_[1] }); $s->output($s->xmlsTag($f->{-fld}, ''=>$v), "\n") } else { $s->output($s->xmlsTag($f->{-fld}, ''=>$v), "\n") } next } elsif ($c->{-hist}) { next if ref($f) ne 'HASH'; next if $f->{-inp} && $f->{-inp}->{-rfd} ? (!$d->{-file}) : (!$f->{-fld} || !exists($d->{$f->{-fld}})); } elsif ($f eq '') { # next col $lr =$hide && ($hide ==2) ? 1 : 0; $hide =0; next } elsif ($f =~/^(\n*)(\t*)$/) { $lr =0; if ($1) { # new lines $s->output((!$lt ? "\n\n\n" : "\n
\n") x (length($1)/length("\n"))); $lr =1; } if ($2) { # skip cells $s->output($lr ? "\n\n\n" : '' , "\n" x length($2)) if !$lt; $lr =0; } next; } elsif ($f eq "\f") { # close table $s->output("\n\n
' , $s->lng(0,'frmLso') , "\n' , $c->{-frmLso} ? $s->htmlField('_frmLso', $s->lng(1,'frmLso') , {-labels=> {ref($c->{-frmLso}) eq 'ARRAY' ? ($c->{-frmLso}->[0]=>$s->lng(0,$c->{-frmLso}->[0])) : ($c->{-frmLso}=>$s->lng(0,$c->{-frmLso})) }} , ref($c->{-frmLso}) eq 'ARRAY' ? $c->{-frmLso}->[0] : $c->{-frmLso}) : () , "\n
' ,'', $s->htmlEscape($rhe->[1]), "' ,$s->htmlEscape($s->udisp($rhe->[2])), "
\n") if !$lt; $lt =1; $lr =1; next } elsif ($f eq '') { # close table & labels $s->output("\n\n\n") if !$lt; $lt =2; $lr =1; next } elsif (!$f) {next} elsif (!ref($f)) {$s->output($f); next} elsif (ref($f) eq 'CODE') {$c->{-mail} && 1 ? eval{ $s->output(&$f($s,$n,$m,$c,$d))} : $s->output(&$f($s,$n,$m,$c,$d)); next} else {} local $_=$d->{$f->{-fld}}; $hide = $qm && ($f->{-flg}||'') =~/[aq]/ # 'a'll, 'q'uery ? 0 : $fr && $fr->{$f->{-fld}} && !ref($fr->{$f->{-fld}}) && ($fr->{$f->{-fld}} >1) ? 1 : ((ref($f->{-hide}) eq 'CODE' ? &{$f->{-hide}} ($s,$f,$fm,$d) && 1 : $f->{-hide} && 1) || (ref($f->{-hidel}) eq 'CODE' ? &{$f->{-hidel}}($s,$f,$fm,$d) && 2 : $f->{-hidel} && 2) || (defined($f->{-flg}) && (!$f->{-flg} ||($f->{-flg}=~/[-]/)) && 1) || ($qm && !$f->{-fld} && 1) || ($qm && defined($f->{-flg}) && ($f->{-flg} !~/[aq]/) && 1) || ($qm && $f->{-inp} && (ref($f->{-inp}) eq 'HASH') && (grep {$f->{-inp}->{$_} } qw(-rows -arows -hrefs -rfd)) && 1)); $edit = !$em ? $qm : $fr && $fr->{$f->{-fld}} && !ref($fr->{$f->{-fld}}) ? 0 : ref($f->{-edit}) eq 'CODE' ? $qm || &{$f->{-edit}}($s,$f,$fm,$d) : exists($f->{-edit}) ? $qm || $f->{-edit} : $f->{-flg} # 'a'll, 'e'dit', 'q'uery ? ($f->{-flg}=~/[ae]/) || ($qm && ($f->{-flg}=~/[aeq]/)) : defined($f->{-flg}) && (!$f->{-flg} ||($f->{-flg}=~/[-]/)) ? 0 : 1; my $fuc =!$hide && $f->{-fld} && $s->mdeFldIU($mt, $f->{-fld}); my $lbl =$s->htmlEscape($s->lnglbl($f,'-fld')); my $cmt =($s->lngcmt($f) ||$s->lng(1, $f->{-fld})) .' [' .$f->{-fld} .($f->{-flg} ? ': ' .$f->{-flg} : '') .']'; $_=$d->{$f->{-fld}}; my $rid =$hide || (exists($f->{-fvhref}) && !$f->{-fvhref}) ? undef : $f->{-fvhref} && !$c->{-print} ? do{ my $v =$s->urlCmd(&{$f->{-fvhref}}($s,$f,$fm,$d)); $v ? '{-mail} ? ' target="_blank"': '') .' >' : undef} : $edit && !$c->{-print} && $f->{-ddlb} && !ref($f->{-ddlb}) && ($f->{-ddlb} !~/\s/) && (!defined($_) || ($_ eq '')) ? '' : !defined($_) || ($_ eq '') || (exists($f->{-form}) && !$f->{-form}) ? undef : !$c->{-print} && ref($f->{-form}) ? do { $_=$d->{$f->{-fld}}; my $v =ref($f->{-form}) eq 'CODE' ? &{$f->{-form}}($s,$f,$fm,$d) : ref($f->{-form}) ? $s->urlCmd('' , -form=> $f->{-form}->[0] || $m->{-table} || $n , !defined($_) || ($_ eq '') ?(-cmd => 'recList') :(-cmd => $f->{-form}->[1] || '' # 'recList' ,-key =>{$f->{-form}->[2] || $f->{-fld} => $_})) : $f->{-form}; $v =$s->urlCmd(@$v) if ref($v); $v ? '{-mail} ? ' target="_blank"': '') .' >' : undef } : !$c->{-print} && ( $f->{-form} || (($f->{-flg}||'')=~/[h]/) || $fuc || ( (($f->{-flg}||'')=~/[aiuq]/) && ($f->{-ddlb} && (!$f->{-ddlbtgt} ? 1 : !ref($f->{-ddlbtgt}) ? ($f->{-ddlbtgt} !~/^<+/) || ($d->{$f->{-fld}} !~/[,;]/) : !ref($f->{-ddlbtgt}->[0]) ? !$f->{-ddlbtgt}->[0] || ($f->{-ddlbtgt}->[0] !~/^<+/) || ($d->{$f->{-fld}} !~/[,;]/) : !$f->{-ddlbtgt}->[0]->[2] || ( $f->{-ddlbtgt}->[0]->[2] =~/\d/ ? $d->{$f->{-fld}} !~/[,;]/ : index($d->{$f->{-fld}}, $f->{-ddlbtgt}->[0]->[2]) <0) ) || $f->{-inp} && ($f->{-inp}->{-values} ||$f->{-inp}->{-labels})) )) ? '{-mail} ? ' target="_blank"': '') .' >' : $qm ? undef : (!$c->{-print} ||$c->{-mail}) && (($m->{-ridRef} ||$s->{-ridRef}) && (grep {$f->{-fld} eq $_ } @{$m->{-ridRef}||$s->{-ridRef}}) || ($f->{-fld} eq ($m->{-rvcActPtr} ||$s->{-rvcActPtr}||'"')) || ($f->{-fld} eq ($m->{-key} && @{$m->{-key}} <2 && $m->{-key}->[0])) ) && (!$f->{-inp} || !(grep {$f->{-inp}->{$_} } qw(-arows -rows -cols -hrefs -htmlopt))) ? '{-mail} ? ' target="_blank"': '') .' >' : undef; $_=$d->{$f->{-fld}}; my $rfn =$hide ||$c->{-print} ? undef : $f->{-fnhtml} ? &{$f->{-fnhtml}}($s,$f,$fm,$d) ||'' : $f->{-fnhref} ? do { my $v =$s->urlCmd(&{$f->{-fnhref}}($s,$f,$fm,$d)); $v ? "{-mail} ? ' target="_blank"': '') .' style="text-decoration: none; font-weight: bolder;" > *' : '' } : undef; $_=$d->{$f->{-fld}}; if ($hide) {$lbl =' '} elsif (defined($f->{-lblhtml})) { my $l =$f->{-lblhtml}; $l =&$l($s,$f,$fm,$d) if ref($l) eq 'CODE'; $l =~s/<\s*input[^<>]*>//ig if !$em; $l =~s/\$_/$lbl/; $lbl =$l } $lbl =$rid .$lbl .'' if $rid && $em && $edit && $lbl !~/1 && (!$f->{-inp} || !$f->{-inp}->{-rfd}) ? '' : $lt ? '{-fhclass} ? ' class="' .(ref($f->{-fhclass}) ? &{$f->{-fhclass}}($s,$f,$fm,$d) : $f->{-fhclass}) .'"' : '') .($f->{-fhstyle} ? ' style="' .(ref($f->{-fhstyle}) ? &{$f->{-fhstyle}}($s,$f,$fm,$d) : $f->{-fhstyle}) .'"' : '') .' title="' .htmlEscape($s,$cmt) .'"' .($f->{-fhprop} ? ' ' .$f->{-fhprop} : '') .'>' .$lbl .'' : $lbl =~/^\s*{-fhclass} ? ' class="' .(ref($f->{-fhclass}) ? &{$f->{-fhclass}}($s,$f,$fm,$d) : $f->{-fhclass}) .'"' : '') .($f->{-fhstyle} ? ' style="' .(ref($f->{-fhstyle}) ? &{$f->{-fhstyle}}($s,$f,$fm,$d) : $f->{-fhstyle}) .'"' : '') # style="padding-left: 0; padding: 0; margin-left: 0; margin: 0; border-left-width: 0; border-width: 0; layout-grid-mode: none;" .' title="' .htmlEscape($s,$cmt) .'"' .($f->{-fhprop} ? ' ' .$f->{-fhprop} : '') .'>' .$lbl .''); if ($f->{-lblhtbr} && !$c->{-hist}) { $lbl =(!$lr ? '' : "\n\n\n") .$lbl ."\n\n\n" if !$lt; $lt =$f->{-lblhtbr} eq '' ? 2 : 1; $lr =0; } $_=$d->{$f->{-fld}}; my $wgp = $hide ? '' : $edit ? htmlField($s, $f->{-fld}, $cmt , $fr && ref($f->{-inp}) && ref($fr->{$f->{-fld}}) ? (ref($fr->{$f->{-fld}}) eq 'HASH' ? $fr->{$f->{-fld}} : {%{$f->{-inp}}, -values=>$fr->{$f->{-fld}}}) : $f->{-inp} , $d->{$f->{-fld}}) : $f->{-inp} && ($f->{-inp}->{-labels} || $f->{-inp}->{-hrefs} || $f->{-inp}->{-htmlopt}) ? htmlField($s, '', $cmt, $f->{-inp}, $d->{$f->{-fld}}) : $fuc || $s->mdeFldRW($mt, $f->{-fld}) ? $s->htmlEscape($s->udisp($d->{$f->{-fld}})) : htmlField($s, '', $cmt, $f->{-inp}, $d->{$f->{-fld}}); $wgp ='' .$wgp if $em && !$qm && !$edit && !$hide && defined($_) && ($_ ne '') # && $fr # !!! commented 2007-04-08 to remove && (!defined($f->{-flg}) ||($f->{-flg} =~/[aeu]/)); # as cgiDBData() if (!$hide && defined($f->{-inphtml})) { my $wgh =$f->{-inphtml}; $wgh =&$wgh($s,$f,$fm,$d) if ref($wgh) eq 'CODE'; $wgh =~s/<\s*input[^<>]*>//ig if !$edit; $wgh =~s/\$_/$wgp/; $wgp =$wgh } $wgp =$rid .$wgp .'' if $rid && !$edit && $wgp !~/{-colspan} ? ' colspan=' .$f->{-colspan} :'') .($f->{-fdclass} ? ' class="' .(ref($f->{-fdclass}) ? &{$f->{-fdclass}}($s,$f,$fm,$d) : $f->{-fdclass}) .'"' : '') .($f->{-fdstyle} ? ' style="' .(ref($f->{-fdstyle}) ? &{$f->{-fdstyle}}($s,$f,$fm,$d) : $f->{-fdstyle}) .'"' : '') .($f->{-fdprop} ? ' ' .$f->{-fdprop} : '') .'>' .$wgp .'' if $wgp !~/^\s*{$f->{-fld}}; if (!$lt) { if ($hide && ($hide ==2)) { } elsif ($f->{-ddlb} && $em && $edit && !$hide) { my $wg1=''; ($wgp, $wg1) =($`, $1) if $wgp =~/(<\/t[dh]>)$/i; $s->output((!$lr ? '' : "\n\n\n"), $lbl, $wgp); $s->cgiDDLB($f, $em, $qm, $d); $s->output($wg1, "\n"); $wgp .=$wg1 } else { $s->output((!$lr ? '' : "\n\n\n"), $lbl, $wgp, "\n"); } } elsif (!$hide) { if ($f->{-ddlb} && $em) { $s->output($lbl, ' ', $wgp); $s->cgiDDLB($f, $em, $qm, $d); $s->output("
\n") } elsif ($wgp ne '') { $s->output($lbl, ' ', $wgp , $wgp =~/<(\/p|br\s*\/)>[\s\r\n]*$/i ? "\n" : "
\n") } elsif ($f->{-lblhtbr} && ($lbl =~/<\/table>[\r\n]*$/i) && !$c->{-hist}) { $s->output("\n\n\n") } } elsif ($f->{-lblhtbr} && ($lbl =~/<\/table>[\r\n]*$/i) && !$c->{-hist}) { $s->output("\n\n\n") } $lr =1 }} if ($qm) { # Query condition fields my $q =($c->{-qlist} && $s->{-form}->{$c->{-qlist}} && $s->{-form}->{$c->{-qlist}}->{-query}) || ($c->{-qlist} && $s->{-table}->{$c->{-qlist}} && $s->{-table}->{$c->{-qlist}}->{-query}) || $m->{-query} ||{}; $s->output($lt ? "
\n\n" : "\n" ); $lt =0; $lr =1; my $th =sub{'' }; my $td ='\n") if $qk; $s->output(&$th($s, '-qjoin'), $td , htmlField($s, '_qjoin', lng($s,1,'-qjoin') , {-size=>50} , $c->{-qjoin}) , "\n") if $de eq 'dbi'; $s->output(&$th($s, '-qwhere'), $td , htmlField($s, '_qwhere', lng($s,1,'-qwhere') .': ' . ($de eq 'dbm' ? "Perl: {fieldname} (eq|[gl][et]) 'value' and|or {fieldname} <>==value..." : "SQL: fieldname <>= 'value' and|or...") , {-arows=>1,-cols=>45} , $c->{-qwhere}) , '' , !$q->{-where} ? () : ref($q->{-where}) eq 'ARRAY' ? htmlEscape($s, ' AND ' .join(' AND ', @{$q->{-where}})) : ref($q->{-where}) ? htmlEscape($s, '(' .$q->{-where} .')') : htmlEscape($s, ' AND ' .$q->{-where}) , $q->{-filter} ? htmlEscape($s, ' FILTER ' .$q->{-filter}) : () , $m && $m->{-qfilter} ? htmlEscape($s, ' FILTER ' .$m->{-qfilter}) : () , "\n"); if ($s->mdeRAC($m)) { $s->output(&$th($s, '-qurole'), $td , htmlField($s, '_qurole', lng($s,1,'-qurole') , {-values=>[$s->mdeRoles($mt)]}, $c->{-qurole}) , htmlField($s, '_quname', lng($s,1,'-quname'), undef, $c->{-quname}) ); $_ =$c->{-quname}; $s->cgiDDLB({-fld=>'_quname', -ddlb=>sub{$_[0]->uglist({})}}, 0, 1, $c); $s->output("\n"); } $s->output(&$th($s, '-qftext'), $td , htmlField($s, '_qftext', lng($s,1,'-qftext') , {-size=>50} , $c->{-qftext}) , "\n"); $s->output(&$th($s, '-qversion'), $td , htmlField($s, '_qversion', lng($s,1,'-qversion'), {-values=>['-','+']}, $c->{-qversion}) , '(' , $q->{-version} || '-', ')' , "\n"); $s->output(&$th($s, '-qorder'), $td , htmlField($s, '_qorder', lng($s,1,'-qorder') , {$de eq 'dbm' ? (-labels=>$qo) :(-asize=>50)} , $c->{-qorder}||'') , '' , $q->{-order} ? htmlEscape($s, '(' .($qo->{$q->{-order}} ||$q->{-order} ||$qo->{$q->{-keyord}} ||$q->{-keyord}) .')') : $de eq 'dbm' ? htmlEscape($s, '(' .($qo->{$KSORD}||$KSORD) .')') : () , '' , "\n") if !$qk; $s->output(&$th($s, '-qorder'), $td , htmlField($s, '_qorder', lng($s,1,'-qorder') , {-asize=>50} , $c->{-qorder}||'') , '' , $q->{-order} ? htmlEscape($s, '(' .($qo->{$q->{-order}} ||$q->{-order}) .')') : () , '' , "\n") if $qk && ($de eq 'dbi'); $s->output(&$th($s, '-qdisplay'), $td , $c->{-frmLsc} ? $s->htmlField('_frmLsc', $s->lng(1,'-frmLsc') , {-labels=>{$c->{-frmLsc} => $s->lnglbl($m->{-mdefld} && $m->{-mdefld}->{$c->{-frmLsc}}, $mt->{-mdefld} && $mt->{-mdefld}->{$c->{-frmLsc}}) ||$s->lng(0,$c->{-frmLsc})}} , $c->{-frmLsc}) : () , !$q->{-group} ? htmlField($s, '_qdisplay', lng($s,1,'-qdisplay') , {-arows=>1,-cols=>45} , $c->{-qdisplay}) : () , "\n") if $c->{-frmLsc} || !$q->{-group}; $s->output(&$th($s, '-qlimit'), $td , htmlField($s, '_qlimit', lng($s,1,'-qlimit') , {-values=>[128,256,512,1024,2048,4096]} , $c->{-qlimit}||'') , '(' , $q->{-limit}||$m->{-limit}||$s->{-limit}||$LIMRS , ')' , "\n"); $s->output(&$th($s, '-style'), $td , htmlField($s, '_style', lng($s,1,'-style'), {-size=>50}, ($c->{-style}||'') =~/\x00/ ? $c->{-style} =$' : $c->{-style}) , htmlField($s, '_xml', lng($s,1,'-xml'), {-labels=>{''=>'','yes'=>'xml'}}) , "\n" ) if 0; my $u =htmlEscape($s, $s->urlCat($s->url(-relative=>1) , '_cmd'=>'recList', '_form'=>$c->{-form} , !(grep {defined($c->{$_}) && ($c->{$_} ne '') } qw (-qkey -qwhere -qurole)) ? ('_qkey'=>'') : () , map { !defined($c->{"-$_"}) ||($c->{"-$_"} eq '') ? () : ("_$_" , ref($c->{"-$_"}) ? $s->strdata($c->{"-$_"}) : $c->{"-$_"}) } qw(qkey qkeyord qjoin qwhere qurole quname qftext qversion qorder qlimit qdisplay frmLso frmLsc style xml) )); $s->output(&$th($s, '-qurl') , $td , '', $u, '' , "\n"); } else { # Read/Edit, should be nothing } $s->output(!$lt ? "
' .htmlEscape($_[0], lng($_[0], 0, $_[1])) .''; my $de =$s->{-table}->{$m->{-table}||$n}; $de =($de && $de->{-dbd})||$s->{-tn}->{-dbd}; my $qo ={qw (all all eq == ge >= gt > le <= lt <)}; $qo ={map {("-a$_", 'asc ' .$qo->{$_}, "-d$_", 'dsc ' .$qo->{$_})} keys %$qo}; my $qk =1; # -qkeyord switch $s->{-pcmd}->{-qkey} =$s->cgiQKey($n,$m ,{map { $_ =~/^_q/ ? () : ($_ => $s->{-pdta}->{$_}) } keys %{$s->{-pdta}}}); $s->output(&$th($s, '-qkeyord'), $td , htmlField($s, '_qkeyord', lng($s,1,'-qkeyord') , {-labels=>$qo} , $c->{-qkeyord}||'') , '' , $q->{-keyord} || ($de eq 'dbm') ? htmlEscape($s, '(' .($q->{-keyord} && $qo->{$q->{-keyord}} ||$q->{-keyord} ||($de eq 'dbm' ? $qo->{$KSORD} ||$KSORD : '') ||'') .')') : () , '' , "
\n" : "\n") if !$c->{-xml}; $s } sub htmlField { # Generate field widget HTML # self, field name, title, meta, value my ($s, $n, $t, $m, $v) =@_; my $wgp =''; my $cs =$n && $s->{-c}->{-htmlclass} ? 'Input ' .$s->{-c}->{-htmlclass} : 'Input'; $v ='' if !defined($v); if (!$n) { # View only if (ref($m) ne 'HASH') { # Textfield $wgp =htmlEscape($s, $v) } elsif ($m->{-htmlopt} && $s->ishtml($v)) { # HTML Text $wgp =$s->trURLhtm($v,sub{$_[1]},sub{$_[1]}) } elsif ($m->{-hrefs}) { # Text & Hyperlinks $wgp =$s->trURLtxt($v , sub { my $v =$_[1]; $v =htmlEscape($_[0], $_[1]); $v =~s/( {2,})/' ' x length($1)/ge; $v =~s/\n/
\n/g; $v =~s/\r//g; $v } , \&trURLhref); $wgp = $s->htfrDiff($wgp) if $s->{-pcmd} && $s->{-pcmd}->{-hist}; # $wgp ='' .$wgp .'' if $v =~/ {2,}/; } elsif (grep {exists($m->{$_})} qw(-arows -rows -cols)) {# Resizeable text $v =htmlEscape($s,$v); $v =~s/( {2,})/' ' x length($1)/ge; $v =~s/\n/
\n/g; $v =~s/\r//g; # $v ="$v" if $v =~/  /; $wgp =$v; } elsif ($m->{-values} ||$m->{-labels}) { # Listbox my $l =lngslot($s, $m, '-labels') || (ref($m->{-values}) eq 'HASH') && $m->{-values}; $l =&{$l}($s) if ref($l) eq 'CODE'; $v =$l->{$v} if $l && defined($l->{$v}); $wgp =htmlEscape($s, $v) } elsif ($m->{-rfd}) { # RFD Filebox $wgp =$s->htmlRFD() } else { # Textfield $wgp =htmlEscape($s, $v) } } elsif (!$m) { # Default text field my $l =defined($v) ? length($v) : 0; $l =$l <20 ? 20 : $l >80 ? 80 : $l; $wgp ='' } elsif (ref($m) eq 'HASH') { if (exists $m->{-arows} || grep {$m->{$_}} qw(-rows -cols -hrefs)) { # Textarea my $a ={%$m}; delete @$a{-hrefs, -arows}; if (exists($m->{-arows})) { my $ar =0; $a->{-cols} =20 if !$a->{-cols}; if ($a->{-wrap} && lc($a->{-wrap}) eq 'off') { my @a =split /\n/, $v; $ar =scalar(@a) } else { foreach my $r (split /\n/, $v) { $ar +=1 +(length($r) >$a->{-cols} ? int(length($r)/$a->{-cols}) +1 :0); } } $a->{-rows} =($m->{-arows} >$ar ? $m->{-arows} : $ar); $a->{-rows} =20 if $a->{-rows} >30; } if (defined($m->{-hrefs})) { my $h =$s->ishtml($v) ? $s->trURLhtm($v, undef, \&trURLhref) : $s->trURLtxt($v, undef, \&trURLhref); $wgp .=join(';  ', @$h); $wgp .='
' if $wgp; } $wgp .=$s->cgi->textarea( ($cs ? (-class=>$cs) : ()) ,(map {($_ => (ref($a->{$_}) eq 'CODE' ? &{$a->{$_}}($s,$a,local($_)=$v) : $a->{$_}))} keys %$a) ,-name=>$n, -title=>$t, -default=>$v, -override=>1); $wgp .="'); ${n}__b.parentNode.insertBefore(r, $n)\n" ."r.contentEditable='true'; r.style.borderStyle='inset'; r.style.borderWidth='thin'; r.normalize; r.innerHTML =!$n.value ? ' ' : $n.value; r.focus();}\n" ."else {${n}__b.value='R'; $n.value=!${n}__r.innerHTML ? '' : ${n}__r.innerHTML.substr(0,1)!='<' && ${n}__r.innerHTML.indexOf('<')>=0 ? '<span></span>' +${n}__r.innerHTML : ${n}__r.innerHTML; ${n}__r.removeNode(true); $n.style.display='inline'; $n.focus();};\n" #${n}__r.innerHTML ? ${n}__r.innerHTML : ''; ${n}__r.removeNode(true); $n.style.display='inline'; $n.focus();};\n" ." return(false)}\" />\n" #MSHTML Edit Control for IE5.5 if $m->{-htmlopt} && ($ENV{HTTP_USER_AGENT}||'') =~/MSIE/; } elsif (exists $m->{-asize}) { # Textfield $wgp =$s->cgi->textfield( ($cs ? (-class=>$cs) : ()) ,(map { $_ ne '-asize' ? ($_=>ref($m->{$_}) ne 'CODE' ? $m->{$_} : &{$m->{$_}}($s,$m,local($_)=$v)) : ('-size'=>do { my $z =$m->{-asize}; $z =(ref($z) ne 'CODE' ? $z : &$z($s,$m,local($_)=$v)) ||20; my $l =defined($v) ? length($v) : 0; $l < $z ? $z : $l >80 ? 80 : $l; }) } keys %$m) ,-name=>$n ,-title=>$t ,-override=>1 ,-default=>$v) } elsif ($m->{-values} ||$m->{-labels}) { # Listbox my $tv =$m->{-values}; $tv =&$tv($s) if ref($tv) eq 'CODE'; my $tl =$s->lngslot($m, '-labels'); $tl =&$tl($s) if ref($tl) eq 'CODE'; $tv =do{use locale; [sort {$tl->{$a} cmp $tl->{$b}} keys %$tl]} if !$tv && $tl; unshift @$tv, $v if defined($v) && ($v ne '') && !grep {$_ eq $v} @$tv; unshift @$tv, '' if $s->{-pcmd}->{-cmg} eq 'recQBF'; $wgp =$s->cgi->popup_menu( ($cs ? (-class=>$cs) : ()) ,($m->{-ddlbloop} ? !ref($m->{-ddlbloop}) || &{$m->{-ddlbloop}}($s) : 0) ||($m->{-loop} ? !ref($m->{-loop}) || &{$m->{-loop}}($s) : 0) ? (-onchange => '{window.document.DBIx_Web._cmd.value="recForm"; window.document.DBIx_Web.submit(); return(false)}') : () ,(map { !defined($m->{$_}) || ($_=~/^(?:-ddlbloop|loop)$/) ? () : ref($m->{$_}) eq 'CODE' ? (do { my $n =$_; local $_ =$v; ($n => &{$m->{$n}}($s,$m,$_)) }) : ($_ => $m->{$_})} keys %$m) ,-name=>$n, -title=>$t , $tv ? (-values=>$tv) : () , $tl ? (-labels=>$tl) : () ,-override=>1,-default=>$v) } elsif ($m->{-rfd}) { # RFD Filebox $wgp =$s->htmlRFD() } else { # Textfield $wgp =$s->cgi->textfield( ($cs ? (-class=>$cs) : ()) ,(map {($_ => (ref($m->{$_}) eq 'CODE' ? &{$m->{$_}}($s,$m,local($_)=$v) : $m->{$_}))} keys %$m) ,-name=>$n,-title=>$t,-override=>1,-default=>$v) } } elsif (ref($m) eq 'CODE') { # Any other... $wgp =&$m(@_) } $wgp } sub trURLtxt { # Translate text with URLs # (text, sub{} txt, sub{} url) -> txt || [url] # !!! restricted -cgibus special urls translation: # _tcb_cmd= -> _cmd= # =-sel -> =recRead # -> _form=... # id= -> _key=... my($s, $vt, $ct, $cu) =@_; my $vr=$ct ? '' : []; my $f; while ($vt =~/(\[{2}[\w-]{3,7}:\/\/[^\n\r]+?\]{2}|\b[\w-]{3,7}:\/\/[^\s\t,()<>\[\]"']+[^\s\t.,;()<>\[\]"'])/) { my($u0,$u,$u1) =($1,$1); $vt =$'; $vr .=&$ct($s,$`) if !ref($vr); if ($u =~/^\[{2}(.+?)\]{2}$/) { $u =$u0 =$1; if ($u =~/(?:\]\[|[|])/) { $u =$`; $u1 =$'; $u0 =$u } $u =$u0 =htmlEscape($s,$u) if $u =~/\s/; } if ($s->{-cgibus} && ($u =~/^(?:url|urlr):/)) { $u =~s/_tcb_cmd=-sel/'_cmd=recRead&_form=' .$s->{-pcmd}->{-form}/ge; $u =~s/_tcb_cmd=-lst/'_cmd=recList&_form=' .$s->{-pcmd}->{-table}/ge; $u =~s/_tsw_FTEXT=/_qftext=/; $u =~s/_tsw_WHERE=/_qwhere=/; $u =~s/&id=/&_key=/g; } if ($u =~/^(?:host|urlh):\/{2,}/) { $u ='/' .$' } elsif ($u =~/^(?:url|urlr):\/{2,}/) { $u =$' } elsif ($u =~/^(?:fsurl|urlf):\/{2,}/) { $f =$s->rfdPath(-url=>$s->{-pcmd}, $s->{-pdta}) ||$s->rfdPath(-urf=>$s->{-pcmd}, $s->{-pdta}) if !$f; $u =~s/^(?:fsurl|urlf):\/{2,}/$f .'\/'/e; } elsif ($u =~/^(?:key|id):\/{2,}/) { my $n =$'; $u ='?_cmd=recRead' .$HS .'_key=' .($n !~/\Q$RISM1\E/ ? ($s->{-pcmd}->{-table} || $s->{-pcmd}->{-form}) .$RISM1 .$n : $n); $u1=urlUnescape($s,$n) if !$u1; } elsif ($u =~/^(?:wikn|name|wiki):\/{2,}/) { my $n=$'; $u ='?_cmd=recRead' .$HS .'_wikn=' .$n; $u1=urlUnescape($s,$n) if !$u1; } if (ref($vr)) {push @$vr, $cu ? &$cu($s,$u,$u1,$u0) : $u} else {$vr .=&$cu($s,$u,$u1,$u0)} } $vr .=&$ct($s,$vt) if !ref($vr); $vr } sub trURLhtm { # Translate text with URLs # (text, sub{} txt, sub{} url) -> html || [url] my($s, $vt, $ct, $cu) =@_; my $vr=$ct ? '' : []; my $f; while ($vt =~/(\s+(?:href|src)\s*=\s*")([^"]+)/i) { my($u0,$u,$u1) =($2,$2); $vt =$'; $vr .=&$ct($s,$` .$1) if !ref($vr); if ($s->{-cgibus} && ($u =~/^(?:url|urlr)/)) { $u =~s/_tcb_cmd=-sel/'_cmd=recRead&_form=' .$s->{-pcmd}->{-form}/ge; $u =~s/_tcb_cmd=-lst/'_cmd=recList&_form=' .$s->{-pcmd}->{-table}/ge; $u =~s/_tsw_FTEXT=/_qftext=/; $u =~s/_tsw_WHERE=/_qwhere=/; $u =~s/&id=/&_key=/g; } if ($u =~/^(?:host|urlh):\/{2,}/) { $u ='/' .$' } elsif ($u =~/^(?:url|urlr):\/{2,}/) { $u =$' } elsif ($u =~/^(?:fsurl|urlf):\/{2,}/) { $f =$s->rfdPath(-url=>$s->{-pcmd}, $s->{-pdta}) ||$s->rfdPath(-urf=>$s->{-pcmd}, $s->{-pdta}) if !$f; $u =~s/^(?:fsurl|urlf):\/{2,}/$f .'\/'/e; } elsif ($u =~/^(?:key|id):\/{2,}/) { $u1=$'; chop($u1) if $u1 =~/\/$/; $u ='?_cmd=recRead' .$HS .'_key=' .($u1 !~/\Q$RISM1\E/ ? ($s->{-pcmd}->{-table} || $s->{-pcmd}->{-form}) .$RISM1 .$u1 : $u1); } elsif ($u =~/^(?:wikn|name|wiki):\/{2,}/) { $u1=$'; chop($u1) if $u1 =~/\/$/; $u ='?_cmd=recRead' .$HS .'_wikn=' .$u1; } if (ref($vr)) {push @$vr, $cu ? &$cu($s,$u,$u1,$u0) : $u} else {$vr .=&$cu($s,$u,$u1,$u0)} } $vr .=&$ct($s,$vt) if !ref($vr); $vr } sub trURLhref { # Translate URL to hyperlink # (url,label,original) -> html my $s=$_[0]; defined($_[2]) ? ('' .htmlEscape($_[0], $_[2]) .'') : ('' .htmlEscape($_[0] , do { my $v = $_[1] =~/^\?_cmd=recRead[;&]_form=([^;&]+)[;&]_key=/ ? $1 .'/' .$' : $_[1] =~/^\?_cmd=recRead;/ ? $' : $_[3] =~/^(?:fsurl|urlf):\/{2,}/ ? $' : $_[1]; $v =~s/;_urm=[^;&]+// if $_[1] =~/^\?/; length($v) >49 ? substr($v,0,47) .'...' : $v }) .'') } sub htmlFVUT { # HTML of text field value with URLs embedded my $v =$_[3]; # (self, table, record, value) $_[0]->rfdStamp($_[1],$_[2]) if !exists($_[2]->{-file}) && ($v =~/\b(?:fsurl|urlf):\/{2,}/); $_[0]->trURLtxt($v , sub { my $v =$_[1]; $v =htmlEscape($_[0], $_[1]); $v =~s/( {2,})/' ' x length($1)/ge; $v =~s/\n/
\n/g; $v =~s/\r//g; $v } , \&trURLhref); } sub htmlFVUH { # HTML of html field value with URLs embedded my $v =$_[3]; # (self, table, record, value) $_[0]->rfdStamp($_[1],$_[2]) if !exists($_[2]->{-file}) && ($v =~/\b(?:fsurl|urlf):\/{2,}/); $_[0]->trURLhtm($v,sub{$_[1]},sub{$_[1]}) } sub htmlRFD { # RFD widget html my ($s, $n, $m, $c, $d) =@_; $n =$s->{-pcmd}->{-form} if !$n || $n=~/^\d*$/; $m =$s->{-form}->{$n}||$s->{-table}->{$n} if !$m; $c =$s->{-pcmd} if !$c; $d =$s->{-pout} if !$d; return('') if !$d->{-file}; my $edt=$s->{-pcmd}->{-edit} && $d->{-file} && $d->{-fupd}; my $pth=$s->rfdPath(-path=>$d->{-file}); my $urf=$s->rfdPath(-urf=>$d->{-file}); my $url=$s->rfdPath(-url=>$d->{-file}); my $fnu='_file_u'; my $fnc='_file_c'; my $fnf='_file_f'; my $fnl='_file_l'; my $fno='_file_o'; my $g =$s->cgi(); my $r =''; if ($edt && $s->cgi->param($fnu)) { # Upload $s->rfaUpload($c, $d, $fnu); } if ($edt && $urf # Close && $s->cgi->param($fnc)) { $s->nfclose($pth, [$s->cgi->param($fnc)]) } if ($edt && $s->cgi->param($fnf)) { # Delete $s->rfaRm($c, $d, [$s->cgi->param($fnl)]) } if ($edt) { # Edit widget my $fo =($s->cgi->param($fno)||$s->cgi->param($fnc)) && $s->nfopens($pth,{}); my $cs =$s->{-c}->{-htmlclass} ? 'Input ' .$s->{-c}->{-htmlclass} : 'Input'; $r .=$s->cgi->filefield(-name=>$fnu ,($cs ? (-class=>$cs) : ()) , -title=>$s->htmlEscape($s->lng(1,'rfauplfld'))) .$s->cgi->submit(-name=>$fnf ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'rfaupdate') , -title=>$s->lng(1,'rfaupdate') , -style=>"width: 3em;") .(!$fo && $^O eq 'MSWin32' ? $s->cgi->submit(-name=>$fno ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'rfaopen') , -title=>$s->lng(1,'rfaopen') , -style=>"width: 2em;") : '') .($fo ? $s->cgi->scrolling_list(-name=>$fnc, -override=>1, -multiple=>'true' , -title=>$s->lng(1,'rfaopen') ,($cs ? (-class=>$cs) : ()) , -values=> ['--- ' .$s->lng(0,'rfaclose') .' ---' ,ref($fo) eq 'HASH' ? sort keys %$fo : @$fo] , ref($fo) eq 'HASH' ? (-labels=>$fo) : ()) : ''); if ($urf && $urf =~/^file:(.*)/i) { my $fs =$1; $fs =~s/\//\\/g; $r .="\n[ ' .$g->a({-href=>$urf, -target=>'_blank'} , $s->htmlEscape($fs)) ." ]
\n"; } else { $r .="\n   \n" } my $v= eval{join('; ', map { my $f =$_; $f=~s/([%])/uc sprintf("%%%02x",ord($1))/ge; $s->cgi->a({-href=>"$url/$f", -target=>'_blank'} , $s->cgi->checkbox(-name=>$fnl ,($cs ? (-class=>$cs) : ()) , -value=>$_ , -label=>$_ , -title=>$s->lng(1,'rfadelm'))) } $s->pthGlobns($pth .'/*'))}; $r .=(defined($v) ? $v : ('
' .$s->htmlEscape($s->lng(0, 'Error')) .': ' .$s->htmlEscape($@) ."\n")) } else { # View widget my $v =eval{join('; ', map { my $f =$_; $f=~s/([%])/uc sprintf("%%%02x",ord($1))/ge; $_ eq '.htaccess' ? () : ($g->a({-href=>"$url/$f",-target=>'_blank'} , $s->htmlRFDimg($_,$pth,$url) . $s->htmlEscape($_))) } $s->pthGlobns($pth .'/*'))}; $r .=' ' .(defined($v) ? $v : ('
' .$s->htmlEscape($s->lng(0, 'Error')) .': ' .$s->htmlEscape($@) ."\n")) } $r } sub htmlRFDimg { # RFD item image HTML my ($s,$f,$d,$u) =@_; # (file, directory, url) -> img tag return('') if !$s->{-icons}; my $p ="$d/$f"; '' } sub cgiDDLB { # CGI Drop-down list box my ($s, $f) =@_; my $v_=$_; my $d =$f->{-ddlb}; my $mv=$f->{-ddlbmult}; my $tg=$f->{-ddlbtgt} ||$f->{-fld}; my $ml=!ref($tg) ? defined($tg) && $tg =~/[+,;]/ : !ref($tg->[0]) ? defined($tg->[0]) && $tg->[0] =~/[+,;]/ : $tg->[0]->[2]; my $nf=$f->{-fld}; my $nl=$nf .'__L'; # List my $no=$nf .'__O'; # Open button my $nc=$nf .'__C'; # Close button my $ne=$nf .'__S'; # Set button my $nr=$nf .'__R'; # Reset button my $rf=undef; # Rows fetched my $cs =$s->{-c}->{-htmlclass} ? 'Input ' .$s->{-c}->{-htmlclass} : 'Input'; my $csc=($cs ? 'class="' .htmlEscape($s, $cs) .'"' : ''); if ($s->{-pdta}->{$ne}) { # real assignment in 'cgiParse' if ($tg =~/^_(quname)/) { $s->{-pcmd}->{$tg} =$s->{-pdta}->{$nl}; } else { $s->{-pout}->{$tg} =$s->{-pdta}->{$nl}; } } if ($s->{-pdta}->{$ne} ||$s->{-pcmd}->{$ne} ||$s->{-pdta}->{$nc}) { $s->output($s->htmlOnLoad("{window.document.DBIx_Web.${nf}.focus()}")); } if (!$s->{-pdta}->{$no} # open button & exit && ($f->{-ddlbloop} ? !$s->{-pdta}->{$ne} && !$s->{-pdta}->{$nr}: 1) ) { if ($f->{-ddlbmsab} && $s->cgi->user_agent('MSIE')) { $s->output(""); } $s->output($s->cgi->submit(-name=>$no ,($cs ? (-class=>$cs) : ()) , $f->{-ddlbmsab} && $s->cgi->user_agent('MSIE') ? (-OnClick=>"if(${no}O('$nf')) {return(false)};") : () , -value=>$s->lng(0, $f->{-ddlbloop} ? 'ddlbopenl' : 'ddlbopen') , -title=>$s->lng(1, $f->{-ddlbloop} ? 'ddlbopenl' : 'ddlbopen') , -style=>"width: 2em;" )); return(''); } my $ek =$s->cgi->user_agent('MSIE') ? 'window.event.keyCode' : 'event.which'; my $fs =sub{ '{var k;' ."var l=window.document.DBIx_Web.$nl;" ."if(l.style.display=='none'){" .($_[0] eq '4' ? '' : 'return(true)') .'}else{' .(!$_[0] # onkeypess - input ? "k=window.document.DBIx_Web.$nf.value +String.fromCharCode($ek);" : $_[0] eq '1' # onkeypess - list -> input (first char) ? "window.document.DBIx_Web.$nf.focus(); k=window.document.DBIx_Web.$nf.value =String.fromCharCode($ek); " : $_[0] eq '2' # onkeypess - list -> prompt (selected char) # ? "k=prompt('Enter search string',String.fromCharCode($ek));" ? "k =String.fromCharCode($ek); for (var i=0; i cgi->user_agent('MSIE') ? 'if (l.options.item(i).value.toLowerCase().indexOf(k)' .($_[0] eq '3' ?'>=' :'==') .'0 || l.options.item(i).innerText.toLowerCase().indexOf(k)' .($_[0] eq '3' ?'>=' :'==') .'0){' : 'if (l.options.item(i).value.toLowerCase().indexOf(k)' .($_[0] eq '3' ?'>=' :'==') .'0 || l.options.item(i).text.toLowerCase().indexOf(k)' .($_[0] eq '3' ?'>=' :'==') .'0){') .'l.selectedIndex =i; break;};}};' .($_[0] && ($_[0] ne '4') ? 'return(false);' : $_[0] && ($_[0] eq '2') ? 'return(false);' : '') .'}}'}; $s->output('") if !$ml; $s->output($s->cgi->submit(-name=>$nr ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'ddlbreset') , -title=>$s->lng(1,'ddlbreset') , -style=>"width: 2em;")) if $f->{-ddlbloop} && (defined($s->{-pout}->{$nf}) && ($s->{-pout}->{$nf} ne '')); $s->output($s->cgi->submit(-name=>$nc ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'ddlbclose') , -title=>$s->lng(1,'ddlbclose') , -style=>"width: 2em;") , "
\n"); my $sl='"); } elsif (ref($d) eq 'HASH') { $s->output($sl, "\n"); use locale; $rf =0; foreach my $e (sort {lc(ref($d->{$a}) ? join(' - ',@{$d->{$a}}) : $d->{$a}) cmp lc(ref($d->{$b}) ? join(' - ',@{$d->{$b}}) : $d->{$b})} keys %$d) { $s->output( '\n"); $rf +=1 } $s->output(""); } elsif ($d && ($s->{-form} && $s->{-form}->{$d} || eval{$s->mdeTable($d)})) { local $s->{-limit} =$s->{-limlb} ||$s->{-limit} || $LIMLB; $s->cgiList($d, undef, undef, undef, $sl); $rf =$s->{-fetched} } else { local $s->{-limit} =$s->{-limlb} ||$s->{-limit} || $LIMLB; $s->cgiList('', {}, {}, $d, $sl); $rf =$s->{-fetched} } if (1 && $f->{-ddlbloop} && defined($_) && ($_ ne '') && defined($rf) && !$rf && $s->{-pdta}->{$ne}) { $s->output($s->htmlOnLoad("{window.document.DBIx_Web.${nl}.style.display=\"none\"}")); return($s) } $s->output("
\n"); if (ref($tg)) { my $n1 =$ne; foreach my $b (ref($tg) ? @$tg : $tg) { my ($n, $l, $m) =ref($b) ? @$b : ($b,$b,($b||'') =~/[+,;]/); $n =$f->{-fld} if !defined($n); $l =($m ? '<+' : '<') .($s->lnglbl($s->{-pcmd} && $s->{-pcmd}->{-cmdf} && $s->{-pcmd}->{-cmdf}->{-mdefld} && $s->{-pcmd}->{-cmdf}->{-mdefld}->{$n} , $s->{-pcmd} && $s->{-pcmd}->{-cmdt} && $s->{-pcmd}->{-cmdt}->{-mdefld} && $s->{-pcmd}->{-cmdt}->{-mdefld}->{$n}) || $s->lng(0, $n)) if !defined($l); my $w =($n =~/^[<+-]*(.+)/ ? $1 : $n); $m =', ' if $m && $m =~/^\d*$/; $s->output($s->cgi->button( -value=>$l ,$n1 ? (-name => $n1) : () , -title=>$s->lng(1,'ddlbsubmit') ,($cs ? (-class=>$cs) : ()) , -onClick=>"{var fs =window.document.DBIx_Web.$nl; " ."var ft =window.document.DBIx_Web.$w; " ."var i =fs.selectedIndex; i =i <0 ? 0 : i; " .($s->cgi->user_agent('MSIE') ?(!$m ? "ft.value =(fs.options.item(i).value ==\"\" ? fs.options.item(i).text : fs.options.item(i).value);}" : "ft.value =(ft.value ==\"\" ? \"\" : (ft.value +\"$m\")) +(fs.options.item(i).value ==\"\" ? fs.options.item(i).text : fs.options.item(i).value);}") :(!$m ? "ft.value =fs[i].value;}" : "ft.value =(ft.value ==\"\" ? \"\" : (ft.value +\"$m\")) +fs[i].value;}") ) )); $n1 =undef; } } else { $s->output($s->cgi->submit(-name=>$ne ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'ddlbsubmit') , -title=>$s->lng(1,'ddlbsubmit'))); } $s->output($s->cgi->button(-value=>$s->lng(0,'ddlbfind') ,($cs ? (-class=>$cs) : ()) ,-title=>$s->lng(1,'ddlbfind') ,-onClick=>&$fs(3) ,-style=>"width: 2em;" )); $s->output($s->cgi->submit(-name=>$nr ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'ddlbreset') , -title=>$s->lng(1,'ddlbreset') , -style=>"width: 2em;")) if $f->{-ddlbloop} && (defined($s->{-pout}->{$nf}) && ($s->{-pout}->{$nf} ne '')); $s->output($s->cgi->submit(-name=>$nc ,($cs ? (-class=>$cs) : ()) , -value=>$s->lng(0,'ddlbclose') , -title=>$s->lng(1,'ddlbclose') , -style=>"width: 2em;"),"\n"); $s->output($s->htmlOnLoad(!$ml ? &$fs(4) : "{window.document.DBIx_Web.${nl}.focus()}")); } sub cgiQKey { # Make Query Key from fields filled my ($s, $n, $m, $v) =@_; $m =$s->{-form}->{$n}||$s->{-table}->{$n} if !$m; my $k ={}; if ($m->{-query} && $m->{-query}->{-data}) { map {$k->{$_} =$v->{$_} } grep { defined($v->{$_}) && ($v->{$_} ne '') } map {$_->{-fld} } grep {ref($_) eq 'HASH' } @{$m->{-query}->{-data}} } elsif ($m->{-field}) { map {$k->{$_} = $v->{$_} } grep { defined($v->{$_}) && ($v->{$_} ne '') } map {$_->{-fld} } grep {ref($_) eq 'HASH' && ($_->{-flg}||'') =~/[aql]/ } @{$m->{-field}} } if (!%$k) { map {$k->{$_} =$v->{$_} } grep { defined($v->{$_}) && ($v->{$_} ne '') } keys %{$v}; } foreach my $e (keys %$k) { # cgiForm/recQBF translation pair next if !$k->{$e} || ($k->{$e} !~/^[\[].+[\]]$/); no warnings; $k->{$e} = eval('sub{' .$k->{$e} .'}') && eval{$s->dsdParse($k->{$e})} || $k->{$e} } $k } sub cgiQuery { # Query records # -query: rows & columns specs ; display specs # + resSel defaults for recSel # + -qkey/key, -qwhere/where cgiQuery # + -frmLso cgiQuery # - -frmLso, -frmLsc cgiQuery # + -meta, -field cgiSel: -data, -display # + -display (,-data) cgiList # - -qhref, -qhrcol, -qfetch, -qfilter cgiList my ($s, $n, $m, $c) =@_; $c =$s->{-pcmd} if !$c; $n =$c->{-table} ||$c->{-form} || $s->{-pcmd}->{-table} || $s->{-pcmd}->{-form} if !$n; $m =$s->{-form}->{$n} ||$s->mdeTable($n) # object meta if !$m; my $q =$m->{-query}; # query my $t =$m->{-table} && $s->mdeTable($m->{-table}) || $m; # table meta local $c->{-cmdf} =$m || $t; # object meta local $c->{-cmdt} =$t || $m; # table meta # Inherit query specs $s->cgiQDflt($n, $m, $c); local @$q{qw(-meta -field -data -display -order -keyord)} =@$q{qw(-meta -field -data -display -order -keyord)}; $s->cgiQInherit($q, $m, $t); # Form Display Options Default if (exists($m->{-frmLso}) && !$m->{-frmLso} || ref($m->{-frmLso})) { } elsif (exists($t->{-frmLso}) && !$t->{-frmLso}) { } elsif (ref($t->{-frmLso})) { $m->{-frmLso} =$t->{-frmLso} } elsif ($s->mdeRAC($m,'-qurole') || $t->{-rvcDelState} || $s->{-rvcDelState} ||$t->{-rvcCkoState} ||$s->{-rvcCkoState}) { my $oe =($t->{-rvcChgState} ||$s->{-rvcChgState}) && $s->tn('-rvcChgState')->[1] ||''; my $oo =($t->{-rvcCkoState} ||$s->{-rvcCkoState}) && $s->tn('-rvcCkoState')->[1] ||''; my $od =($t->{-rvcDelState} ||$s->{-rvcDelState}) && $s->tn('-rvcDelState')->[1] ||''; my $ov =($t->{-rvcActPtr} ||$s->{-rvcActPtr}) && 'tvmVersions'; my $of =$oe && $od; my $ob =$t->{-rvcUpdWhen} && (($t->{-dbd} ||$s->{-dbd} ||$s->{-tn}->{-dbd}) eq 'dbi') && (($q->{-order}||'') ne ($t->{-rvcUpdWhen} .' desc')); my $ou =[$s->mdeRoles($t)]; my $oa =!(exists($m->{-frmLsoAdd}) && !$m->{-frmLsoAdd}) && ($m->{-frmLsoAdd}||$t->{-frmLsoAdd}); my $off=$s->lng(0,'frmLsoff') ||'-------------'; $m->{-frmLso} = [(1 && @$ou ?(['-urole' =>$off]) : ()) ,(grep {$_ ne 'all'} @$ou) ,(1 && ($oe ||$oo ||$od ||$of ||$ov) ?(['-todo' =>$off]) : ()) ,($of ? (['todo']) :()) ,($oe ? ([$oe]) :()) # ,($oo ? ([$oo]) :()) ,($of ? (['done']) :()) ,($od ? ([$od]) :()) ,($ov ? ([$ov]) :()) # ,['recQBF' =>'...'] ]; if (ref($oa) eq 'CODE') { &{$m->{-frmLsoAdd}||$t->{-frmLsoAdd}}($s, $n, $m, $c, exists($c->{-frmLso}) ? $c->{-frmLso}||'' : ()) } elsif (ref($oa) eq 'ARRAY') { push @{$m->{-frmLso}} ,(substr(ref($oa->[0]) eq 'HASH' ? $oa->[0]->{-val}||$oa->[0]->{-lbl} : $oa->[0]->[0], 0, 1) ne '-' ? (['-add' =>$off]) : ()) , @$oa } } # Form Display Options Parser if ($m->{-frmLso} ||($t->{-frmLso} && !exists($m->{-frmLso})) || $m->{-frmLso0A} ||($t->{-frmLso0A} && !exists($m->{-frmLso0A}))) { my $ml =$m->{-frmLso} ||$t->{-frmLso}; my $oe =($t->{-rvcChgState} ||$s->{-rvcChgState}) && $s->tn('-rvcChgState')->[1] ||''; my $oo =($t->{-rvcCkoState} ||$s->{-rvcCkoState}) && $s->tn('-rvcCkoState')->[1] ||''; my $od =($t->{-rvcDelState} ||$s->{-rvcDelState}) && $s->tn('-rvcDelState')->[1] ||''; my $ov =($t->{-rvcActPtr} ||$s->{-rvcActPtr}) && 'tvmVersions'; my $oa =($m->{-frmLsoAdd}||$t->{-frmLsoAdd}); my $qo =($c->{-qkeyord} ||$q->{-keyord} ||''); my $qq =$c->{-qwhere} && ( ($c->{-qwhere} =~/^(\[\[.*?\]\])/) || ($c->{-qwhere} =~/^(\/\*.*?\*\/)/)) && $1; $c->{-frmLso} =$c->{-qurole} if !exists($c->{-frmLso}) && !$s->uguest() && $c->{-qurole}; $c->{-frmLso} ='tvmVersions' if !exists($c->{-frmLso}) && $ov && $c->{-qversion} && ($c->{-qversion} !~/-/); $c->{-frmLso} ='' if !exists($c->{-frmLso}); foreach my $lso (ref($c->{-frmLso}) ? @{$c->{-frmLso}} : !exists($c->{-frmLso}) || !defined($c->{-frmLso}) ? '' : $c->{-frmLso}) { if ($m->{-frmLso0A} && &{$m->{-frmLso0A}}($s, $n, $m, $c, exists($c->{-frmLso}) ? $lso||'' : ())) { } elsif ($t->{-frmLso0A} && ($m ne $t) && &{$t->{-frmLso0A}}($s, $n, $t, $c, exists($c->{-frmLso}) ? $lso||'' : ())) { } elsif ($lso eq '-all') { # elsif (!$lso && exists($c->{-frmLso})) { delete $c->{-qurole} if !$c->{-quname}; delete $c->{-qorder} if $t->{-rvcUpdWhen}; foreach my $v (map {$t->{$_} ||$s->{$_} ||$s->tn($_) } qw (-rvcChgState -rvcCkoState -rvcDelState -rvcFinState)) { if (!ref($v) || !$c->{-qkey} || !defined($c->{-qkey}->{$v->[0]})) {} else { delete $c->{-qkey}->{$v->[0]}; delete $c->{-qversion}; delete $c->{-qkeyord}; } } delete $c->{-qversion}; foreach my $e (ref($ml) eq 'ARRAY' ? @$ml : ref($ml) eq 'CODE' ? @{&$ml($s, $n, $m, $c, exists($c->{-frmLso}) ? $c->{-frmLso} ||'' : ())} : ()) { next if !ref($e); my $x =ref($e) eq 'HASH' ? $e->{-cmd} : $e->[2]; next if !$x || (ref($x) ne 'HASH'); delete @{$c}{keys %$x}; delete @{$c->{-qkey}}{keys %{$x->{-qkeyadd}}} if $c->{-qkey} && $x->{-qkeyadd}; } } elsif (do{ my $rv =undef; foreach my $e (ref($ml) eq 'ARRAY' ? @$ml : ref($ml) eq 'CODE' ? @{&$ml($s, $n, $m, $c, exists($c->{-frmLso}) ? $c->{-frmLso} ||'' : ())} : ()) { next if !ref($e) || ($lso ne (ref($e) eq 'HASH' ? $e->{-val} ||$e->{-lbl} : $e->[0])); my $x =ref($e) eq 'HASH' ? $e->{-cmd} : $e->[2]; next if !$x; $rv =$x; last } if (ref($rv) eq 'CODE') { &$rv($s, $n, $m, $c, exists($c->{-frmLso}) ? $lso||'' : ()) } elsif (ref($rv) eq 'HASH') { @{$c}{keys %$rv} =values %$rv; $c->{-qwhere} =$qq .$rv->{-qwhere} if $qq && $rv->{-qwhere}; if ($c->{-qkeyadd}) { $c->{-qkey} ={} if !$c->{-qkey}; @{$c->{-qkey}}{keys %{$c->{-qkeyadd}}} =values %{$c->{-qkeyadd}}; delete $c->{-qkeyadd} } } $rv }) { } elsif ($lso eq '-urole') { delete $c->{-qurole}; delete $c->{-quname}; } elsif ($s->grep1(sub{$lso eq $_}, $s->mdeRoles(0))) { $c->{-qurole}=$lso } elsif ($lso eq '-todo') { foreach my $v (map {$t->{$_} ||$s->{$_} ||$s->tn($_) } qw (-rvcChgState -rvcCkoState -rvcDelState -rvcFinState)) { if (!ref($v) || !$c->{-qkey} || !defined($c->{-qkey}->{$v->[0]})) {} else { delete $c->{-qkey}->{$v->[0]}; delete $c->{-qversion}; delete $c->{-qkeyord}; } } delete $c->{-qversion}; } elsif ($lso eq 'todo') { delete $c->{-qversion}; my $f =$t->{-rvcFinState} ||$s->{-rvcFinState} ||$s->tn('-rvcFinState'); my $v =ref($f) ? [$f->[0] ,grep { my $v =$_; !grep {$v eq $_} @$f } @{$t->{-rvcAllState} ||$s->{-rvcAllState} ||$s->tn('-rvcAllState') ||[]}] : ($t->{-rvcChgState} ||$s->{-rvcChgState} ||$s->tn('-rvcChgState')); $c->{-qkey} ={} if $v && !$c->{-qkey}; $c->{-qkey}->{$v->[0]} =[@{$v}[1..$#{@$v}]] if $v; $c->{-qkeyord} ='-aeq' if $qo; } elsif ($lso eq 'done') { delete $c->{-qversion}; my $v =$t->{-rvcFinState} ||$s->{-rvcFinState} ||$s->tn('-rvcFinState'); if (!ref($v)) { my $f =[@{$t->{-rvcChgState} ||$s->{-rvcChgState} ||$s->tn('-rvcChgState') ||[]}, @{$t->{-rvcDelState} ||$s->{-rvcDelState} ||$s->tn('-rvcDelState') ||[]}]; $v =[$f->[0] ,grep { my $v =$_; !grep {$v eq $_} @$f } @{$t->{-rvcAllState} ||$s->{-rvcAllState} ||$s->tn('-rvcAllState') ||[]}] } $c->{-qkey} ={} if $v && !$c->{-qkey}; $c->{-qkey}->{$v->[0]} =[@{$v}[1..$#{@$v}]] if $v; $c->{-qkeyord} ='-deq' if $qo; } elsif ($oe && ($lso eq $oe)) { $c->{-qversion} ='+'; my $v =$t->{-rvcChgState} ||$s->{-rvcChgState} ||$s->tn('-rvcChgState'); $c->{-qkey} ={} if $v && !$c->{-qkey}; $c->{-qkey}->{$v->[0]} =[@{$v}[1..$#{@$v}]] if $v; $c->{-qkeyord} ='-deq' if $qo; } elsif ($oo && ($lso eq $oo)) { $c->{-qversion} ='+'; my $v =$t->{-rvcCkoState} ||$s->{-rvcCkoState} ||$s->tn('-rvcCkoState'); $c->{-qkey} ={} if $v && !$c->{-qkey}; $c->{-qkey}->{$v->[0]} =[@{$v}[1..$#{@$v}]] if $v; $c->{-qkeyord} ='-deq' if $qo; } elsif ($od && ($lso eq $od)) { $c->{-qversion} ='+'; my $v =$t->{-rvcDelState} ||$s->{-rvcDelState} ||$s->tn('-rvcDelState'); $c->{-qkey} ={} if $v && !$c->{-qkey}; $c->{-qkey}->{$v->[0]} =[@{$v}[1..$#{@$v}]] if $v; $c->{-qkeyord} ='-deq' if $qo; } elsif ($ov && ($lso eq $ov)) { $c->{-qversion} ='+'; if ($c->{-qkey}) { foreach my $k (qw(-rvcFinState -rvcChgState -rvcCkoState -rvcDelState)) { my $v =$t->{$k} ||$s->{$k} ||$s->tn($k); delete $c->{-qkey}->{$v->[0]} if $v; } } } elsif ($lso eq '-add') { foreach my $e (ref($oa) eq 'ARRAY' ? @$oa : ()) { next if !ref($e); my $x =ref($e) eq 'HASH' ? $e->{-cmd} : $e->[2]; next if !$x || (ref($x) ne 'HASH'); delete @{$c}{keys %$x}; delete @{$c->{-qkey}}{keys %{$x->{-qkeyadd}}} if $c->{-qkey} && $x->{-qkeyadd}; } $c->{-qwhere} =$qq if $qq; }} $c->{-frmLso} =$c->{-frmLso}->[0] if ref($c->{-frmLso}); } my %a =$q ? %$q : (); # Query Arguments # Query Key $a{-key} ={} if $q->{-key} || $c->{-qkey}; @{$a{-key}}{keys %{$q->{-key}}} =values %{$q->{-key}} if $q->{-key}; @{$a{-key}}{keys %{$c->{-qkey}}} =values %{$c->{-qkey}} if $c->{-qkey}; # Query Where if (!$c->{-qwhere}) {} elsif (!$a{-where}) {$a{-where} =$c->{-qwhere}} elsif (ref($a{-where}) eq 'ARRAY') {push @{$a{-where}}, $c->{-qwhere}} elsif (ref($a{-where})) {$a{-where} =$c->{-qwhere}} else {$a{-where} ='(' .$a{-where} .') and (' .$c->{-qwhere} .')'} $a{-meta} =$m; # Query Other Clauses $a{-table} =$m->{-table} ||$n if !$a{-table}; $a{-join2} =$c->{-qjoin} if exists($c->{-qjoin}) && $c->{-qwhere}; $a{-urole} =$c->{-qurole} if exists($c->{-qurole}); $a{-uname} =$c->{-quname} if $c->{-quname}; $a{-ftext} =$c->{-qftext} if exists($c->{-qftext}); $a{-version} =$c->{-qversion} if $c->{-qversion}; $a{-order} =$c->{-qorder} if $c->{-qorder}; $a{-keyord} =$c->{-qkeyord} if $c->{-qkeyord}; $a{-limit} =$c->{-qlimit} if $c->{-qlimit}; $a{-display} =ref($c->{-qdisplay}) ? $c->{-qdisplay} : [split /\s*[,;]\s*/, $c->{-qdisplay}] if $c->{-qdisplay}; $a{-datainc} =ref($c->{-qdatainc}) ? $c->{-qdatainc} : [split /\s*[,;]\s*/, $c->{-qdatainc}] if $c->{-qdatainc}; if (exists($m->{-frmLsc}) ? $m->{-frmLsc} : ($m->{-frmLsc} ||$t->{-frmLsc})) { my $lsc =$m->{-frmLsc} ||$t->{-frmLsc}; my $lsq =$c->{-frmLsc} ||(ref($lsc->[0]) eq 'HASH' ? $lsc->[0]->{-val} : $lsc->[0]->[0]); foreach my $e (@$lsc) { next if $lsq ne (ref($e) eq 'HASH' ? $e->{-val} : $e->[0]); my $x =ref($e) eq 'HASH' ? $e->{-cmd} : $e->[2]; if (ref($x) eq 'CODE') { &$x($s, $n, $m, \%a, $lsq); last; } if (!$x) { my $v =(ref($e) eq 'HASH' ? $e->{-val} : $e->[0]); $a{-display}->[0] =$v if ref($a{-display}); push @{$a{-data}}, $v if ref($a{-data}) && !grep {$_ && ($v eq $_)} @{$a{-data}}; $a{-order} =$v if !ref($a{-order}); $a{-order}->[0] =$v if ref($a{-order}); } @a{keys %$x} =values %$x; if ($x->{-keyadd}) { $a{-key} ={} if !$a{-key}; @{$a{-key}}{keys %{$x->{-keyadd}}} =values %{$x->{-keyadd}}; delete $a{-keyadd} } foreach my $k (qw(-qhref -qhrcol)) { next if !$a{$k}; $c->{$k} =$a{$k}; delete $a{$k} } last; } } $m->{-frmLso0C} ? &{$m->{-frmLso0C}}($s, $n, $m, \%a, exists($c->{-frmLso}) ? $c->{-frmLso}||'' : ()) : $t->{-frmLso0C} && !exists($m->{-frmLso0C}) ? &{$t->{-frmLso0C}}($s, $n, $t, \%a, exists($c->{-frmLso}) ? $c->{-frmLso}||'' : ()) : undef; $s->cgiSel(\%a); } sub cgiSel { # Select records from database my $q =ref($_[1]) ? $_[1] : {@_[1..$#_]}; local @$q{qw(-meta -field -data -display -order -keyord)} =@$q{qw(-meta -field -data -display -order -keyord)}; $_[0]->cgiQInherit($q); local $q->{-where} =$q->{-where}; if ($q->{-where} && !ref($q->{-where}) && ($q->{-where} =~/^(?:\[\[|\/\*)/)) { my $a =''; while (($q->{-where} =~/^\[\[(.*?)\]\]/) ||($q->{-where} =~/^\/\*(.*?)\*\//)) { $a =!$1 ? $a : $a ? "$a AND ($1)" : "($1)"; $q->{-where} =$' } $q->{-where} =join(' AND ', $a ? ($a) : (), $q->{-where} ? ('(' .$q->{-where} .')') : ()) } $_[0]->recSel($q); } sub cgiQueryFv { # Query field values # (self, form ||{cmd} ||false, field ||[fields], ?{query}) my ($s, $w, $f, $q) =@_; return($s->cgiQuery(ref($w) ? $w->{-table} : $w ,{ -table=>ref($w) ? $w->{-table} : $w ,-query=>{-data=>ref($f) ? $f : [$f] , -display=>ref($f) ? $f : [$f] , -order=>$f , -group=>$f , -keyord=>'-aall'} ,-qhref=>{-key=>[ref($f) ? $f->[0] : $f] , -form=>ref($w) ? $w->{-table} : $w , -cmd=>'recList'}} ,$q ||{} )) } sub cgiQDflt { # Default query arguments fulfill my($s, $n, $m, $c) =@_; # (self, name, meta, command) $c =$s->{-pcmd} if !$c; unless (defined($c->{-qkey}) ||defined($c->{-qwhere}) ||defined($c->{-qurole})) { $m =$s->{-form}->{$n ||$c->{-form} ||$c->{-table}} ||$s->mdeTable($n ||$c->{-table} ||$c->{-form}) if !$m; my $q =$m->{-query}; $c->{-qjoin} = defined($c->{-qwhere}) && defined($c->{-qjoin}) ? $c->{-qjoin} : ($q &&( ref($q->{-qjoin}) eq 'CODE' ? &{$q->{-qjoin}}($s, $n, $m, $c) : $q->{-qjoin})); $c->{-qkey} = defined($c->{-qkey}) ? $c->{-qkey} : ref($q->{-qkey}) eq 'CODE' ? &{$q->{-qkey}}($s, $n, $m, $c) : ref($q->{-qkey}) ? {%{$q->{-qkey}}} : $q->{-qkey}; $c->{-qwhere} = defined($c->{-qwhere}) ? $c->{-qwhere} : ($q &&( ref($q->{-qwhere}) eq 'CODE' ? &{$q->{-qwhere}}($s, $n, $m, $c) : $q->{-qwhere})); $c->{-qurole} = defined($c->{-qurole}) ? $c->{-qurole} : $q->{-urole}; $c->{-quname} = defined($c->{-quname}) ? $c->{-quname} : $c->{-qurole} ? $q->{-uname} : ''; $c->{-qftext} = defined($c->{-qftext}) ? $c->{-qftext} : $q->{-ftext}; $c->{-frmLso} = defined($c->{-frmLso}) ? $c->{-frmLso} : ref($q->{-frmLso}) eq 'CODE' ? &{$q->{-frmLso}}($s,$n,$m,$c) : ref($q->{-frmLso}) ? [grep {my $v =$_; $s->uguest() ? !grep /^$v$/, $s->mdeRoles(0) : 1 } @{$q->{-frmLso}}] : $s->uguest() && $q->{-frmLso} && do { my $v =$q->{-frmLso}; grep /\Q$v\E/, $s->mdeRoles(0)} ? undef : $c->{-qurole} && !$s->uguest() && !$c->{-quname} ? $c->{-qurole} : $q->{-frmLso}; $c->{-frmLsc} = defined($c->{-frmLsc}) ? $c->{-frmLsc} : ref($q->{-frmLsc}) eq 'CODE' ? &{$q->{-frmLsc}}($s,$n,$m) : ref($q->{-frmLsc}) ? [@{$q->{-frmLsc}}] : $q->{-frmLsc}; foreach my $k (qw(-qjoin -qkey -qwhere -qurole -quname -qftext -frmLso -frmLsc)) { delete $c->{$k} if !defined($c->{$k}); } } $s } sub cgiQInherit { # Inherit cgi query attributes if needed my($s, $q, $qm, $tm) =@_; # (self, query, meta, table meta, table query) # use local @$q{qw(-meta -field -data -display -order -keyord)} =@$q{qw(-meta -field -data -display -order -keyord)}; # meta - process -query specification - fill inheritance for formulas # !meta - process request formed - fill metadata for cgiList $tm = !$q->{-table} ? $tm : !ref($q->{-table}) && ($q->{-table} =~/^([^\s]+)/) ? $_[0]->{-form}->{$1} || $_[0]->mdeTable($1) : ref($q->{-table}->[0]) ? $_[0]->mdeTable($q->{-table}->[0]->[0]) : ($q->{-table}->[0] =~/^([^\s]+)/) && $_[0]->mdeTable($1) if !$tm; # return(&{$s->{-die}}("cgiQInherit -> no table meta" .$s->{-ermd})) if !$tm; $q->{-meta} = (ref($q->{-meta}) && $q->{-meta}) || ($q->{-meta} && ($_[0]->{-form}->{$q->{-meta}} || $_[0]->mdeTable($q->{-meta}))) || $tm if !$qm; my $qmv =$qm ||$q->{-meta}; # return(&{$s->{-die}}("cgiQInherit -> no query meta" .$s->{-ermd})) if !$qmv; if ($qm) { foreach my $n (qw(-data -display -order)) { next if !ref($q->{$n}); $q->{$n} =[@{$q->{$n}}]; } } foreach my $m ($q, $qmv, ($qmv ne $tm) ? $tm : ()) { next if !$m; if (!$q->{-data}) { $q->{-field}=$m->{-field} if !$q->{-field}; $q->{-data} = ($m->{-data} && [@{$m->{-data}}]) || ($m->{-query} && $m->{-query}->{-data} && [@{$m->{-query}->{-data}}]) || ($m->{-field} && [grep {(ref($_) eq 'HASH') && $_->{-fld} && ( (($_->{-flg}||'') =~/[akwqlf]/) ||(!defined($_->{-flg}) && (ref($_->{-inp}) ne 'HASH' ? 1 : !( $_->{-inp}->{-rows} ||$_->{-inp}->{-arows} ||$_->{-inp}->{-hrefs} ||$_->{-inp}->{-rfd})) ) ) } @{$m->{-field}}]) if !$q->{-data}; delete $q->{-data} if !$q->{-data} || !@{$q->{-data}}; $q->{-display}= ($m->{-display} && [@{$m->{-display}}]) || ($m->{-query} && $m->{-query}->{-display} && [@{$m->{-query}->{-display}}]) || ($q->{-data} && [map { (ref($_) ne 'HASH') || (($_->{-flg}||'') !~/[al]/i) || !$_->{-fld} ? () : $_->{-fld} } @{$q->{-data}}]) if !$q->{-display}; delete $q->{-display} if !$q->{-display} || !@{$q->{-display}}; } if (!$q->{-order}) { $q->{-order} = ($m->{-order} && (ref($m->{-order}) ? [@{$m->{-order}}] : $m->{-order})) || ($m->{-query} && $m->{-query}->{-order} && (ref($m->{-query}->{-order}) ? [@{$m->{-query}->{-order}}] : $m->{-query}->{-order})); $q->{-keyord} =$m->{-keyord} ||($m->{-query} && $m->{-query}->{-keyord}) if !$q->{-keyord}; } } delete $q->{-meta} if !$q->{-meta} || $qm; delete $q->{-field} if !$q->{-field} || !@{$q->{-field}} || $qm; delete $q->{-data} if !$q->{-data} || !@{$q->{-data}}; delete $q->{-display} if !$q->{-display} || !@{$q->{-display}}; delete $q->{-order} if !$q->{-order}; delete $q->{-keyord} if !$q->{-keyord}; if ($q->{-data} && ($q->{-display} || $q->{-datainc})) { foreach my $e ($q->{-display} ? @{$q->{-display}}: () ,$q->{-datainc} ? @{$q->{-datainc}}: ()) { my $n = !ref($e) ? $e : ref($e) eq 'HASH' ? $e->{-fld} : ref($e) eq 'ARRAY' ? $e->[0] : undef; next if !$n || (grep {!ref($_) ? $_ eq $n : ref($_) eq 'HASH' ? ($_->{-fld}||'') eq $n : ref($_) eq 'ARRAY' ? ($_->[0]||'') eq $n : 0 } @{$q->{-data}}); push @{$q->{-data}}, $tm && $tm->{-mdefld}->{$e} || $e; } } $q } sub htmlMQH { # Menu Query Hyperlink # -label / -html # -title, -style, -class, -target; reserved/ignored -tdstyle, -tdclass # -qwhere, -qkey, -qurole, -quname, -qorder, -qkeyord # -xpar=>0 | 1 | 2 | name | [list] # -xkey=>name | [list] my $s =$_[0]; my $a =$#_ ==1 ? $_[1] : {@_[1..$#_]}; my $qf= # full inbound query to match required $s->{-c}->{-htmbHref} ||do {$s->{-c}->{-htmbHref} = {(map { my $v =$s->{-pcmd}->{$_} ; ! defined($v) ? () : ($_ => $v) } qw (-qwhere -qkey -frmLsc -frmLso)) ,(map { my $v =$s->{-pcmd}->{"-q$_"} || ($s->{-pcmd}->{-cmdf} && $s->{-pcmd}->{-cmdf}->{-query} && $s->{-pcmd}->{-cmdf}->{-query}->{"-$_"}) || ($s->{-pcmd}->{-cmdt} && $s->{-pcmd}->{-cmdt}->{-query} && $s->{-pcmd}->{-cmdt}->{-query}->{"-$_"}); ! defined($v) ? () : ref($v) eq 'CODE' ? ("-q$_" => &$v($s, $s->{-pcmd}->{-form}||$s->{-pcmd}->{-table}||'', $s->{-pcmd}->{-cmdf}, $s->{-pcmd})) : ("-q$_" => $v) } qw (urole uname order keyord)) }}; my $qq= # query reqired {map { ($_ =~/^-(?:q|frmLso|frmLsc)/) && defined($a->{$_}) ? ($_ => $a->{$_}) : () } keys %$a}; my $qw= # writing query joining required { -form => $a->{-form} ||$s->{-pcmd}->{-form} , (map {$a->{$_} ? ($_ => $a->{$_}) : () } qw (-cmd -urm)) , !defined($a->{-xpar}) || ($a->{-xpar} eq '1') # excluding some ? (map {$s->{-pcmd}->{$_} ? ($_ => $s->{-pcmd}->{$_}) : () } qw (-qftext -frmLsc)) : !$a->{-xpar} || ($a->{-xpar} !~/^\d/) # excluding list ? (map {($_ =~/^-(?:q|frmLsc|frmLso)/) && $s->{-pcmd}->{$_} ? ($_ => $s->{-pcmd}->{$_}) : () } keys %{$s->{-pcmd}}) : ()}; # excluding all if($a->{-xpar} && ($a->{-xpar} !~/^\d/)) { delete @$qw{ref($a->{-xpar}) ? @{$a->{-xpar}} : $a->{-xpar}}; } if ($a->{-xkey} && $qw->{-qkey}) { $qw->{-qkey} ={%{$qw->{-qkey}}}; delete @{$qw->{-qkey}}{ref($a->{-xkey}) ? @{$a->{-xkey}} : $a->{-xkey}}; } if (!$qq->{-qwhere} && $qw->{-qwhere} && (($qw->{-qwhere} =~/^\[\[(.*?)\]\]/) ||($qw->{-qwhere} =~/^\/\*(.*?)\*\//)) ) { $qw->{-qwhere} =$' } my $ql=800; # query length limit, was 200 # MSDN: METHOD Attribute | method Property: # the URL cannot be longer than 2048 bytes if (length($s->urlCmd('', %$qw)) >$ql) { delete $qw->{-qkey}; } if (length($s->urlCmd('', %$qw)) >$ql) { delete $qw->{-qwhere}; delete $qw->{-qjoin}; } my $qm=1; # query match foreach my $k (keys %$qq) { next if !defined($qq->{$k}); my ($vf, $vq) =($qf->{$k}, $qq->{$k}); if ($qm) { $qm =0 if !defined($vf) ? ( $k eq '-quname' ? !grep /^\Q$vq\E$/i, @{$s->ugnames()} : ($k eq '-frmLso') && defined($qf->{-qurole}) ? $vq ne $qf->{-qurole} : 1) : $k eq '-qwhere' ? $vf !~/\Q$vq\E/ : !ref($vq) && !ref($vf) ? $vq ne $vf : (ref($vq) eq 'ARRAY') || (ref($vf) eq 'ARRAY') ? (do { my $v =$s->strdata($vq); $s->strdata($vf) !~/^\Q$vq\E/}) : (ref($vq) eq 'HASH') && (ref($vf) eq 'HASH') ? (grep {!defined($vf->{$_}) || ($s->strdata($vq->{$_}) ne $s->strdata($vf->{$_})) } keys %$vq) : (ref($vq) xor ref($vf)) ? $s->strdata($vq) ne $s->strdata($vf) : $vq ne $vf; } $qw->{$k} =$k eq '-qkey' ? ($qw->{$k} && $vq ? {%{$qw->{$k}}, %$vq} : $vq) : $k eq '-qwhere' ? ( !$vf ? $vq : $vf =~/\Q$vq\E/ ? $vf : $vq =~/^(?:\[\[|\/\*)/ ? (do{ $vf =($vf =~/^\[\[(.*?)\]\]/) ||($vf =~/^\/\*(.*?)\*\//) ? $' : $vf; $vq .$vf }) : $vq) : $vq; $qw->{$k} =$vq if length($s->urlCmd('', %$qw)) >$ql; } $s->{-pcmd}->{-htmlMQH} = $a if $qm; local $a->{-href} = $s->urlCmd('', %$qw); local $a->{-OnClick}=$s->urlCmd('', %$qw , $s->{-pcmd}->{-frame} ? (-frame=>$s->{-pcmd}->{-frame}) : ()); # !!! Mozilla no OnLoad target local $a->{-target}= '_self' if !$a->{-target}; local $a->{-class} = join(' ' ,($s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) : ()) ,('MenuArea MenuComment') ,($s->{-uiclass} ? ' ' .$s->{-uiclass} : ()) ,($a->{-class} ? $a->{-class} : ()) ,($qm ? 'htmlMQH htmlMQHsel' : 'htmlMQH') ); local $a->{-style} = join('; ' ,($s->{-c}->{-htmlstyle} ? $s->htmlEscape($s->{-c}->{-htmlstyle}) : ()) ,($qm && 0 ? 'text-decoration: none; font-weight: bolder; border-style: inset;' : ()) ,($s->{-uistyle} ? ' ' .$s->{-uistyle} : ()) ,($a->{-style} ? $a->{-style} : ()) ); $s->cgi->a({(map {$a->{$_} ? ($_ => $a->{$_}) : () } qw (-class -style -target -href -title)) , $a->{-OnClick} ? (-OnClick=>"window.document.open('" .$a->{-OnClick} ."','_self','',false); return(false)" ) : ()} , defined($a->{-html}) ? $a->{-html} : defined($a->{-label}) ? '' .$s->htmlEscape($a->{-label}) .'' : ($a->{-html} ||$a->{-label})) } sub cgiList { # List queried records # self, ?options, form name, ?metadata, ?command, ?iterator, ?borders my ($s, $o, $n, $m, $c, $i, $b) =($_[0], substr($_[1],0,1) eq '-' ? @_[1..$#_] : ('-', @_[1..$#_])); $m =$s->{-form}->{$n}||$s->mdeTable($n)||{} if !$m; $c =$s->{-pcmd}||{} if !$c; my $mt =$m->{-table} && $s->mdeTable($m->{-table}) || $m; my $mf =$c->{-field} || $m->{-field} || $mt->{-field}; local $c->{-cmdt} =$mt || $m; # table meta local $c->{-cmdf} =$m || $mt; # object meta $i = !$i ? $s->cgiSel(%{$m->{-query}}, -form=>$n) : ref($i) eq 'HASH' ? (!($i->{-form} ||$i->{-table}) ? $s->cgiSel(-form=>$n, %$i) : $s->cgiSel($i)) : ref($i) eq 'ARRAY' ? eval{my $a =$i; DBIx::Web::ccbHandle->new(sub{shift @$a})} : ref($i) eq 'CODE' ? DBIx::Web::dbmCursor->new($i) : $i; $i ||return(&{$s->{-die}}('cgiList(' .strdata(@_) .') -> cursor undefined' .$s->{-ermd})); my $xml=$c->{-xml}; my $hcls ='class="' .($s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) .' ' : '') .(!$b ? 'ListTable' : 'ListList') .($s->{-uiclass} ? ' ' .$s->{-uiclass} : ''); my $hstl =$hcls .'"' .($s->{-uistyle} ? ' style="' .$s->{-uistyle} .'"' : ''); my $disp =$c->{-qdisplay} || ($i && $i->{-query} && $i->{-query}->{-display}) || $m->{-qdisplay}; $disp =[split /\s*[,;]\s*/, $disp] if !ref($disp) && defined($disp); my $href =$c->{-qhref} ||$m->{-qhref} ||{}; $href->{-form} =$m->{-table}||$n if (ref($href) eq 'HASH') && !$href->{-form}; $href->{-cmd} ='recRead' if (ref($href) eq 'HASH') && !$href->{-cmd}; # -formfld, -key my $hrcol =(defined($c->{-qhrcol}) ? $c->{-qhrcol} : $m->{-qhrcol}) || 0; my @colf =(); # col fields: name, number, heading, td, struct my $coln =sub{return($_[1]) if !$i->{NAME}; my $n =lc(ref($_[0]) ? $_[0]->{-fld} : $_[0]); for(my $k =0; $k <=$#{$i->{NAME}}; $k++) { return($k) if $n eq lc($i->{NAME}->[$k])}; $#{$i->{NAME}} +1}; my $qflgh =($o =~/!.*h/) && ($c->{-qflghtml} || $m->{-qflghtml}); $qflgh =$c->{-qflghtml} if $c->{-qflghtml}; $qflgh ="" .$qflgh .'' if $qflgh && $hstl; my $tstrt =undef; my $fetch =$c->{-qfetch} || $m->{-qfetch}; my $limit =$c->{-qlimit} || ($m->{-query} && $m->{-query}->{-limit}) ||$m->{-limit} ||$s->{-limit} ||$LIMRS; my $tcf0 ='\n"; my $tcf1 ='onclick="DBIxWebListTableTCF(this)"'; # onfocus= $b = # bondaries: # 0 1 2 8 9
3 4 5' ' 6'' 7
# 0 1 2 8 9
3 5 6'' 7
# 0 # !$b->[2] == \n" ? [$b, '\n", ""] : ["", ' ', ' ', " ', ' ', '', ' ', "$b\n", "\n"] if !ref($b); if (ref($href) eq 'HASH') { if (!$href->{-key}) { # Hyperlink key $href->{-key} =[]; my $j =0; my $k =(ref($m->{-key}) eq 'ARRAY') && $m->{-key}; foreach my $f (@$mf) { next if ref($f) ne 'HASH' ||!$f->{-fld}; push @{$href->{-key}}, [$f->{-fld} =>&$coln($f,$j)] if ($f->{-flg}||'') =~/[k]/ # 'k'ey || ($k && grep {$f->{-fld} eq $_} @$k); $j++ } } elsif((ref($href->{-key}) eq 'ARRAY') || !ref($href->{-key})) { foreach my $k (ref($href->{-key}) ? @{$href->{-key}} : ($href->{-key})) { next if ref($k); if ($i->{NAME}) { $k =ref($href->{-key}) ? [$k, &$coln($k)] : &$coln($k); next } my $j =0; foreach my $f (@$mf) { next if ref($f) ne 'HASH' ||!$f->{-fld}; if ($k eq $f->{-fld}) { $k =ref($href->{-key}) ? [$k, $j] : $j; last } $j++ } } } if (!$href->{-urm}) { # Hyperlink unread mark $href->{-urm} =[]; my $j =0; my $k =((ref($m->{-urm}) eq 'ARRAY') && $m->{-urm}) || ((ref($mt->{-urm}) eq 'ARRAY') && $mt->{-urm}) || ((ref($m->{-wkey}) eq 'ARRAY') && $m->{-wkey}); foreach my $f (@$mf) { next if ref($f) ne 'HASH' ||!$f->{-fld}; push @{$href->{-urm}}, [$f->{-fld} =>&$coln($f,$j)] if $k ? (grep {$f->{-fld} eq $_} @$k) : ( ($f->{-flg}||'') =~/[w]/ # 'w'here key && ($f->{-flg}||'') !~/[k]/ # 'k'ey ); $j++ } } elsif ((ref($href->{-urm}) eq 'ARRAY') || !ref($href->{-urm})) { foreach my $k (ref($href->{-urm}) ? @{$href->{-urm}} : $href->{-urm}) { next if ref($k); if ($i->{NAME}) { $k =ref($href->{-urm}) ? [$k, &$coln($k)] : &$coln($k); next } my $j =0; foreach my $f (@$mf) { next if ref($f) ne 'HASH' ||!$f->{-fld}; if ($k eq $f->{-fld}) { $k =ref($href->{-urm}) ? [$k, $j] : $j; last } $j++ } } } if ($href->{-formfld}) { # Hyperlink form my $j =0; if ($i->{NAME}) { $j =&$coln($href->{-formfld}); $href->{-form} =sub{$_[1]->[$j]} } else { foreach my $f (@$mf) { next if ref($f) ne 'HASH' ||!$f->{-fld}; if (($f->{-fld}||'') eq $href->{-formfld}) { $href->{-form} =sub{$_[1]->[$j]}; last } $j++ } } } elsif (defined($href->{-formfld})) { $href->{-form} ='' } if (1) { # Hyperlink sub{} my $hr =$href; $href =sub{ '?' .'_cmd=' .urlEscape($s , ref($hr->{-cmd}) ne 'CODE' ? $hr->{-cmd} : (&{$hr->{-cmd}}(@_))) .$HS .'_form=' .urlEscape($s , ref($hr->{-form}) ne 'CODE' ? $hr->{-form} : (&{$hr->{-form}}(@_))) .$HS .'_key=' .urlEscape($s , !ref($hr->{-key}) ? $_[1]->[$hr->{-key}] : ref($hr->{-key}) ne 'CODE' ? strdatah($s, map {($_->[0] => $_[1]->[$_->[1]])} @{$hr->{-key}}) : &{$hr->{-key}}(@_)) .$HS .'_urm=' .urlEscape($s , !ref($hr->{-urm}) ? $_[1]->[$hr->{-urm}] : ref($hr->{-urm}) ne 'CODE' ? join(',',map {$_[1]->[$_->[1]] ? ($_[1]->[$_->[1]]) : ()} @{$hr->{-urm}}) : &{$hr->{-urm}}(@_)) }; } } $href =sub{''} if !$href; if (!@colf) { # Display column numbers my $j =0; foreach my $e ($disp ? @$disp : $i->{NAME} ? @{$i->{NAME}} : @$mf) { my $f =undef; if ($disp || $i->{NAME}) { foreach my $v (@$mf) { next if ref($v) ne 'HASH' ||!$v->{-fld} ||lc($v->{-fld}) ne $e; $f =$v; last } $f ={-fld=>$e} if !$f } else { next if ref($e) ne 'HASH' ||!$e->{-fld}; $f =$e } $j =&$coln($f, $j); push @colf # name, number/-lsthtml, heading/-ldclass, td, struct , [$f->{-fld} || '' , ref($f->{-lsthtml}) eq 'CODE' ? do{ my($i, $c) =($j, $f->{-lsthtml}); sub{local $_=ref($_[4]) ? $_[4]->[$i] : $_[4]; &$c} } : $f->{-inp} && !$xml && (ref($s->lngslot($f->{-inp}, '-labels')) eq 'HASH') ? do{ my($i, $c) =($j, $s->lngslot($f->{-inp}, '-labels')); $c = {map {$c->{$_} && ($c->{$_} =~/^[_\s]+/) ? ($_ => $') : ($_ => $c->{$_}) } keys %$c} if $c; sub{ local $_=ref($_[4]) ? $_[4]->[$i] : $_[4]; htmlEscape(undef, defined($c->{$_}) && defined($c->{$_}) ? $c->{$_} : $_)} } : $j , $s->lnglbl($f, '-fld')||'' # heading , !$b->[2] || $xml # || (!$f->{-ldclass} && !$f->{-ldstyle} && !$f->{-ldprop}) || ($b->[2] !~/^<.*>$/) ? $b->[2] : do { my $v =$b->[2]; # if (ref($f->{-ldclass})) { my($i,$cs,$w) =($j, $f->{-ldclass}, $v); $v =sub {my $v =ref($w) ? &$w : $w; local $_=ref($_[4]) ? $_[4]->[$i] : $_[4]; $v =~/\sclass\s*=\s*"/ ? $v =~s/\sclass\s*=\s*"([^"]*)"/' class="' .$1 .'; ' .&$cs .'"'/ie : $v =~s/^(.+)(>)$/$1 .' class="' .&$cs .'"' .$2/ie; $v} } elsif ($f->{-ldclass}) { $v =~/\sclass\s*=\s*"/ ? $v =~s/\sclass\s*=\s*"([^"]*)"/' class="' .$1 .' ' .$f->{-ldclass} .'"'/ie : $v =~s/^(.+)(>)$/$1 .' class="' .$f->{-ldclass} .'"' .$2/ie } if (ref($f->{-ldstyle})) { my($i,$cs,$cp,$w) =($j, $f->{-ldstyle}, $f->{-ldprop}, $v); $v =sub {my $v =ref($w) ? &$w : $w; local $_=ref($_[4]) ? $_[4]->[$i] :$_[4]; $v =~/\sstyle\s*=\s*"/ ? $v =~s/\sstyle\s*=\s*"([^"]*)"/' style="' .$1 .'; ' .&$cs .'"'/ie : $v =~s/^(.+)(>)$/$1 .' style="' .&$cs .'"' .$2/ie; $v =~s/^(.+)(>)$/$1 .' ' .(ref($cp) ? &$cp : $cp) .'>'/ie if $cp; $v} } elsif ($f->{-ldstyle}) { $v =~/\sstyle\s*=\s*"/ ? $v =~s/\sstyle\s*=\s*"([^"]*)"/' style="' .$1 .'; ' .$f->{-ldstyle} .'"'/ie : $v =~s/^(.+)(>)$/$1 .' style="' .$f->{-ldstyle} .'"' .$2/ie; $v =~s/^(.+)(>)$/$1 .' ' .$f->{-ldprop} .'>'/ie if $f->{-ldprop}; } elsif ($f->{-ldprop}) { $v =~s/^(.+)(>)$/$1 .' ' .$f->{-ldprop} .'>'/ie } else { } $v } , $f] if $disp || $f->{-lsthtml} || (($f->{-flg}||'') =~/[l]/); $j++ } if (!@colf && isa($i, 'HASH')) { @colf =map {[$i->{NAME}->[$_], $_, $i->{NAME}->[$_] , $b->[2] # , {}]} (0..$#{$i->{NAME}}); foreach my $h (@colf) { foreach my $f (@$mf) { next if (ref($f) ne 'HASH') || !$f->{-fld} || ($f->{-fld} ne $h->[2]); $h->[2] =$s->lnglbl($f,'-fld')||'' } } } } $tstrt =sub{ # Table start sub{} $s->output($b->[0]); # if ($xml || !@colf || $b->[0] !~/
{-frmLsc} || ($mt->{-frmLsc} && !exists($m->{-frmLsc}))) { my $lsc =$m->{-frmLsc} ||$mt->{-frmLsc}; my $lsf =$mt->{-mdefld} ||{}; my $hstl1 =$hstl =~/(class=")/ ? $` .$1 .'Input ' .$' : $hstl; $tho =[@{$colf[0]}]; $tho->[2] = sub{ use locale; my $lsq =$_[0]->{-pcmd}->{-frmLsc} ||(ref($lsc->[0]) eq 'HASH' ? $lsc->[0]->{-val} : $lsc->[0]->[0]); '\n" } } elsif ($m->{-frmLso2C} || ($mt->{-frmLso2C} && !exists($m->{-frmLso2C}))) { $tho =[@{$colf[0]}]; $tho->[2] =$m->{-frmLso2C} ||$mt->{-frmLso2C}; } $s->output("\n" , (map {('\n")} $tho ? ($tho, @colf[1..$#colf]) : @colf) , "\n") } elsif (0 && $b->[0] =~/
[4]->{-lhclass} ? ' ' .$_->[4]->{-lhclass} .'"': '"') .($_->[4]->{-lhstyle} ? ' style="' .$_->[4]->{-lhstyle} .'"' : '') .' title="' .htmlEscape($s, lngcmt($s, $_->[4]) ||$s->lng(1, $_->[0]) ||$_->[2]) .'"' .($_->[4]->{-lhprop} ? ' ' .$_->[4]->{-lhprop} : '') .'>' ,ref($_->[2]) ? &{$_->[2]}($s, $n, $m, $c) : htmlEscape($s, $_->[2]) ,"
output("\n" , (map {('\n")} @colf) , "\n") } }; if (ref($fetch) ne 'CODE') { # Fetch sub{} my $ft =$fetch; my $hrc1=$hrcol+1; # $b->[4] || $#colf ? $hrcol+1 : $hrcol; my $cargo; $fetch =sub { my $r; while($r =$i->fetch()) { last if !$m->{-qfilter} || &{$m->{-qfilter}}($s, $n, $m, $c, $i->{-rec}) } return(undef) if !$r; if ($qflgh) { $s->output((ref($qflgh) eq 'CODE' ? &$qflgh($s) : $qflgh)); &$tstrt(); $qflgh =undef } my $h =&$href($s, $r); $xml ? $s->output('' , xmlsTag($s, 'tr', 'href'=>$s->url .'/' .$h, '0') , "\n" , (map { ref($_->[1]) ? ('<', $_->[0], '>' , &{$_->[1]}($s, $cargo, undef, $i, $r) , '[0], ">\n") : xmlsTag($s, $_->[0] , ''=> ref($_->[1]) ? &{$_->[1]}($s, $cargo, undef, $i, $r) : ref($r) ? $r->[$_->[1]] : $r , "\n") } @colf) ,$b->[8]) # : $s->output($b->[1] # ||[3]) ? &{$_->[3]}($s, $cargo, $h, $i, $r) : $_->[3]) ||htmlEscBlnk($s, ref($r) ? $r->[$_->[1]] : $r) , $b->[3] # , $b->[4] && $h, $b->[4] # "> || '' , ref($_->[1]) ? &{$_->[1]}($s, $cargo, $h, $i, $r) : htmlEscBlnk($s, ref($r) ? $r->[$_->[1]] : $r) , $b->[5], $b->[7] # ||'_ )} @colf[0..$hrcol]) , (map {($b->[6] # '' || ' - ' , ref($_->[3]) ? &{$_->[3]}($s, $cargo, undef, $i, $r) : $_->[3] # $b->[2] , ref($_->[1]) ? &{$_->[1]}($s, $cargo, undef, $i, $r) : htmlEscBlnk($s, ref($r) ? $r->[$_->[1]] : $r) , $b->[7] # )} @colf[$hrc1..$#colf]) ,$b->[8]) # } } &$tstrt() if !$qflgh; # Table start my $j =0; while (&$fetch($s, $i, $b)) { # Fetch data $j++; last if $j >$limit; } $s->{-fetched} =$j; $s->{-limited} =$limit; eval {$i->finish}; $s->output($b->[9]) if !$qflgh; # Table end } sub cgiLst { # Simplified 'cgiList' to embed into 'cgiForm' my $s =shift; # (?options, view, ? query) my $o =$_[0] =~/^-/ ? shift : '-!h'; my ($f, $q) =@_; return($s->cgiList($o, $f, undef, {} ,$s->cgiQuery($f, undef, {})) ) if !$q; $q ={%$q}; foreach my $k (qw(urole uname)) { $q->{"-q$k"} =$q->{"-$k"} if exists($q->{"-$k"}) && !exists($q->{"-q$k"}) } foreach my $k (qw(key where ftext version order keyord limit display datainc)) { $q->{"-q$k"} =$q->{"-$k"} if $q->{"-$k"} && !$q->{"-q$k"} } $s->cgiList($o, $f, undef, $q ||{} ,$s->cgiQuery($f, undef, $q)) } sub cgiHelp { # Print CGI Help screen form # self, form name, form meta, command, data my ($s, $n, $m, $c, $d) =@_; $m =$s->{-form}->{$n}||eval{$s->mdeTable($n)} if !$m; $c =$s->{-pcmd} if !$c; $d =$s->{-pout} if !$d; my $mt=ref($m) && $m->{-table} ? eval{$s->mdeTable($m->{-table})} : $m; my $cs =join(' ' ,$s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) : () ,$s->{-uiclass} ? $s->{-uiclass} : ()); my $cs1 =$cs ? 'class="' .$cs .'"' : ''; my $cs2 =$cs ? 'class="' .$cs .'"' : ''; my $th1 ="
[4]->{-lhclass} ? ' ' .$_->[4]->{-lhclass} .'"': '"') .($_->[4]->{-lhstyle} ? ' style="' .$_->[4]->{-lhstyle} .'"' : '') .($_->[4]->{-lhprop} ? ' ' .$_->[4]->{-lhprop} : '') ,">
"; my $td1 =""; my $th2 =""; my $td2 =""; my $th3 =$th2; my $td3 =$td2; my $cfs ='
'; my $cfe ='
'; my ($th, @td); my $hl =$LNG->{$s->{-lng}} || $LNG->{''}; my $cl =sub{ my $t =$_[0]; my ($c, $v); $c =$t; $v =$c && $hl->{$c} && $hl->{$c}->[0]; return($v) if $v; $c =substr($t,0,1) eq '-' ? substr($t,1) : $t; $v =$c && $hl->{$c} && $hl->{$c}->[0]; return($v) if $v; $t #ucfirst($c) }; my $cv =sub{ my $v =$_[0]; !defined($v) ? 'undef' : $v eq '' ? $s->dsdQuot($v) : ref($v) eq 'CODE' ? 'CODE()' : ref($v) ? $s->dsdQuot($v) : $v}; my $cf; $cf =sub { # (meta, name) return(join(', ', map {&$cf($_[0],$_,$#_ >1 ? @_[2..$#_] : ()) } @{$_[1]}) ) if ref($_[1]) eq 'ARRAY'; my $f =!$_[1] ? undef : (($_[0]->{-mdefld} && $_[0]->{-mdefld}->{$_[1]}) || ($mt && $mt->{-mdefld} && $mt->{-mdefld}->{$_[1]})); $_[2] && $f ? $s->htmlEscape($s->lngcmt($f) ||$s->lng(1,$_[1])) : $_[2] ? '' : $f ? '' .$s->htmlEscape($s->strquot($s->lnglbl($f) ||$s->lng(0,$_[1]))) .'' : (wantarray() ? () : $s->htmlEscape($s->strquot($_[1]))) }; my $hff={ 'a' =>"all" ,'k' =>"key" ,'w' =>"wkey" ,'e' =>"edit" ,'u' =>"update" ,'m' =>"mandatory" ,'h' =>"hyperlik" ,'q' =>"query" ,'l' =>"list" ,'f' =>"fetch" ,'n' =>"numeric" ,'9' =>"numeric" ,'"' =>"string" }; my $cff=sub { return('') if !$_[0]; join(', ' , map { $hff->{$_} ? $hff->{$_} : $_ } split / */, $_[0]) }; my $ce =sub { my $v =$s->htmlEscape(@_); $v =~s/[\r\n]+/
/g; $v }; my $ch =sub { my $v =ref($_[0]) ? &{$_[0]}($s) : $_[0]; return $v if ($s->ishtml($v)); &$ce($v) }; $s->output("\n\n"); if ($s->lngslot($s,'-help')) { $s->output("" ,$th1 ,'' ,'', $td1 ,&$ch($s->lngslot($s,'-help')) ,"
\n" ); } if (1) { $s->htmlMChs() if !$s->{-menuchs}; if ($s->{-menuchs}) { $s->output( "", $th1, '','' , $td1 , join(', ' , map { my ($on, $ol, $ot) =ref($_) eq 'ARRAY' ? (@$_) : ($_); $on =$' if $on =~/[.^&+]+$/; my $o =$s->{-form}->{$on} ||$s->{-table}->{$on}; if ($o && !$ol) { $ol=$_[0]->lngslot($o,'-lbl') if $o; $ol=&$ol($_[0]) if ref($ol); $ol =$ol ||$on; } if ($o) { $ot=$_[0]->lngslot($o,'-cmt'); $ot=&$ot($_[0]) if ref($ot); $ot =$ot ||$on; } $ol ? '' .$s->htmlEscape($ol) .'' : () } @{$s->{-menuchs}}) , "
\n" ); } } foreach my $oc ('f','t') { my $om; my $on; if ($oc eq 'f') { $on =$n; $om =$s->{-form}->{$n}; } elsif ($oc eq 't') { $om =$s->{-form}->{$n}; $om =!$om ? eval{$s->mdeTable($on =$n)} : $om->{-table} ? eval{$s->mdeTable($on =$om->{-table})} : eval{$s->mdeTable($on =$n)}; } next if !$om; $s->output("" ,$th1, "
" ,$s->htmlEscape($s->lnglbl($om)||'') ,'' ,$td1, "
" ,&$ce($s->lngcmt($om)||'') ,"\n" ); $s->output("" ,$th2 ,'' ,$td2 ,&$ch($s->lngslot($om,'-help')||'') ,"\n" ) if $s->lngslot($om,'-help'); $th =join(' ', $on ? $on : ()); $th =join('; ' , $th ? $th : () , map { !exists($om->{$_}) && !exists($s->{$_}) ? () : $s->htmlEscape($_ .'=> ' .&$cv(exists($om->{$_}) ? $om->{$_} : $s->{$_})) } ($om->{-table} && !ref($om->{-table}) ? qw(-table) : ()) , qw(-expr -null) , (grep {/^-(?:cgc|cgv|subst|redirect)/ } sort keys %$om)); $s->output("",$th2,'',$td2,$cfs,$th,"$cfe\n") if $th; ($th, @td) =($s->htmlEscape(&$cl('-key'))); foreach my $k ( qw(-key) , $oc eq 't' ? qw(-wikn) : () , qw(-wkey) , $oc eq 't' ? qw(-ridRef) : ()) { next if !exists($om->{$k}) && !exists($s->{$k}); my $td =&$cf($om, $om->{$k} ||$s->{$k}); $td .=($hl->{$k} && $hl->{$k}->[1] ? ' - ' .$s->htmlEscape($hl->{$k}->[1]) : '') if $td; push @td, $td if $td; } $s->output("",$td1,$th,'',$td2,join("\n$td1$td2", @td),"\n") if @td; ($th, @td) =($s->htmlEscape(&$cl('-rvcActPtr'))); foreach my $k ( $oc eq 't' && ($om->{-rvcActPtr} ||$s->{-rvcActPtr}) ? qw(-rvcChgState -rvcCkoState -rvcDelState) : ()) { next if !exists($om->{$k}) && !exists($s->{$k}); my $td =$om->{$k}->[0] && &$cf($om,$om->{$k}->[0]); next if !$td; my $f =($om->{-mdefld} && $om->{-mdefld}->{$om->{$k}->[0]}) || ($mt->{-mdefld} && $mt->{-mdefld}->{$om->{$k}->[0]}); my $l =$s->lngslot($f->{-inp},'-labels') ||$f->{-inp}->{-labels} if $f && $f->{-inp}; $l =undef if ref($l) ne 'HASH'; $f = ref($f->{-inp}->{-values}) eq 'ARRAY' ? {map {($_=>$l && $l->{$_} ||$s->lng(0,$_) ||$_) } @{$f->{-inp}->{-values}}} : $l if $f && $f->{-inp}; my $v =join(', ' , map{ !$f ? $s->strquot($s->lng(0,$_)||$_) : $f->{$_} ? $s->strquot($f->{$_}) : () } @{$om->{$k}}[1..$#{$om->{$k}}]); $td =$v ? $td .' = ' .$v : ''; next if !$td; $td .=($hl->{$k} && $hl->{$k}->[1] ? ' - ' .$s->htmlEscape($hl->{$k}->[1]) : ''); push @td, $td if $td; } { my $k ='-rvcActPtr'; my $v =&$cf($om, $om->{$k} ||$s->{$k}); $v .=$hl->{$k} && $hl->{$k}->[1] ? ' - ' .$s->htmlEscape($hl->{$k}->[1]) : '' if $v; unshift @td, $v if $v && @td; } $s->output("",$td1,$th,'',$td2,join("\n$td1$td2", @td),"\n") if @td; ($th, @td) =($s->htmlEscape(&$cl('-racUser'))); foreach my $k ( $oc eq 't' ?($s->{-rac} ? qw(-racWriter -racReader) : () , qw(-racActor -racManager -racPrincipal -racUser)) : ()) { next if !exists($om->{$k}) && !exists($s->{$k}); my $td =&$cf($om, $om->{$k} ||$s->{$k}); $td .=($hl->{$k} && $hl->{$k}->[1] ? ' - ' .$s->htmlEscape($hl->{$k}->[1]) : '') if $td; push @td, $td if $td; } $s->output("",$td1,$th,'',$td2,join("\n$td1$td2", @td),"\n") if @td; ($th, @td) =($s->htmlEscape(&$cl('-query'))); # no -frmLso -frmLsoAdd foreach my $k (qw(-query) ) { next if !exists($om->{$k}) && !exists($s->{$k}); my $td =$cfs .$s->htmlEscape(&$cv(exists($om->{$k}) ? $om->{$k} : $s->{$k})) .$cfe; push @td, $s->lng(1,$k) .':', $td if $td; my @td1 =map {$_ eq 'all' ? () : $s->htmlEscape($s->strquot($s->lng(0,$_)) # .($s->lng(1,$_) ? ' - ' .$s->lng(1,$_) : '') ) } $s->mdeRoles($mt) if $td; push @td, &$cl('-frmLso') . ': ' .join(', ', @td1) if @td && @td1 } $s->output("",$td1,$th,'',$td2,join("\n$td1$td2", @td),"\n") if @td; ($th, @td) =($s->htmlEscape(&$cl('-frmLsc'))); foreach my $k (qw(-frmLsc) ) { next if !exists($om->{$k}) && !exists($s->{$k}); my $td =join('
' , map { my ($e, $el, $ec) =$_; if (ref($e) eq 'HASH') { $el =$s->htmlEscape($s->lngslot($e,'-lbl')) || $e->{-val} && &$cf($om,$e->{-val}); $ec =$s->htmlEscape($s->lngslot($e,'-cmt')) || $e->{-val} && &$cf($om,$e->{-val},1); } elsif (ref($e) eq 'ARRAY') { $el =$s->htmlEscape($e->[1]) ||&$cf($om,$e->[0]); $ec =&$cf($om,$e->[0],1); } $el && $ec ? $el .' - ' .$ec : $el ? $el : () } @{$om->{$k}}); push @td, $td if $td; } $s->output("",$td1,$th,'',$td2,join("\n$td1$td2", @td),"\n") if @td; if ($om->{-field} && (ref($om->{-field}) eq 'ARRAY')) { foreach my $f (@{$om->{-field}}) { next if ref($f) ne 'HASH'; $s->output("" ,$th2 ,$s->htmlEscape($s->lnglbl($f) ||($f->{-fld} && $s->lng(0,$f->{-fld})) ||'') ,'' ,$td2 ,&$ce($s->lngcmt($f) ||($f->{-fld} && $s->lng(1,$f->{-fld})) ||'') ,"\n" ); $s->output("" ,$th2 ,'' ,$td2 ,&$ce($s->lngslot($f,'-help')||'') ,"\n" ) if $s->lngslot($f,'-help'); $th =join(' ' , $f->{-fld} ? $s->htmlEscape(&$cv($f->{-fld})) : () , $f->{-flg} ? $s->htmlEscape("(" .&$cff($f->{-flg}) .")") : () ); $th =join('; ' , $th ? $th : () , map { !exists($f->{$_}) ? () : $s->htmlEscape($_ .'=> ' .&$cv($f->{$_})) } qw(-expr -null -edit -hide -hidel -inp -ddlb -ddlbmult -ddlbtgt) ); $s->output("",$th2,'',$td2,$cfs,$th,"$cfe\n") if $th; } } } $s->output("\n
\n"); $s } sub cgiFooter { # Footer of CGI screen my ($s) =@_; my $cs =($s->{-c}->{-htmlclass} ? $s->htmlEscape($s->{-c}->{-htmlclass}) .' ' : '') .'FooterArea'; return(undef) if $s->{-pcmd}->{-xml} ||$s->{-pcmd}->{-print}; if ($s->{-cgi} && $s->{-cgi}->{'.cgi_error'} && (($s->{-c}->{'.cgi_error'} ||'') ne $s->{-cgi}->{'.cgi_error'})) { $_[0]->logRec('error','CGI', $s->{-cgi}->{'.cgi_error'}) } # $s->logRec('***','perl' # ,$] # ,'@INC',@INC # # , 'Win32::LoginName', Win32::LoginName() # ); # $s->logRec('***','%ENV' # ,map {($_, (defined($ENV{$_}) ? $ENV{$_} : 'undef')) # } qw(SERVER_SOFTWARE SERVER_PROTOCOL GATEWAY_INTERFACE PERLXS SCRIPT_NAME PATH_INFO PATH_TRANSLATED REQUEST_METHOD REQUEST_URI QUERY_STRING REDIRECT_QUERY_STRING CONTENT_TYPE CONTENT_LENGTH)); # $s->logRec('***','CGI' # ,(map { my $v =eval("\$CGI::$_"); # ("\$$_", defined($v) ? $v : 'undef') # } qw (VERSION TAINTED MOD_PERL XHTML NOSTICKY NPH PRIVATE_TEMPFILES TABINDEX CLOSE_UPLOAD_FILES POST_MAX HEADERS_ONCE USE_PARAM_SEMICOLONS)) # ,(map { my $v =$s->url(!$_ ? () : ($_=>1)); # (($_||'%url'), (defined($v) ? $v : 'undef')) # } '', qw(-absolute -relative -base)) # # ,'-self_url', ($s->cgi->self_url()||'') # ); # if ($s->{-cgi} && $s->{-cgi}->{dbix_web}) { # foreach my $v (split /[\n\r]+/, $s->{-cgi}->{dbix_web}) { # $_[0]->logRec('***','CGI','dbix_web',$v) # } # } # $s->logRec('***','param' # ,map {($_, (defined($s->cgi->param($_)) ? $s->cgi->param($_) : 'undef')) # } $s->cgi->param); $s->output("\n" ,'' ,'
' ,"\n" ,($s->cgiHook('recList') && defined($s->{-fetched}) ? ('',$s->{-limited} && ($s->{-limited} <=$s->{-fetched}) ?($s->{-limited}, ' / ?') :($s->{-fetched}||0) ,' ', $s->lng(1, '-fetched'),"
\n") : defined($s->{-affected}) ? ('',$s->{-affected}||0, ' ', $s->lng(1, '-affected'),"
\n") : ()) ,"\n" ,'' ,"
\n" ,$s->{-c}->{-logm} && $s->{-debug} ? join(";

\n", map { !defined($_) ? () : $_ =~/^((?:WARN|WARNING|DIE|ERROR)[:.,\s]+)(.*)$/i ? '' .htmlEscape($s, $1) .'' .htmlEscape($s, $2) : htmlEscape($s, $_) } @{$s->{-c}->{-logm}} ) : () ,"\n"); } ######################################################### # Templates or Default Data Definitions ######################################################### sub tn { # Template Naming # (self, metaname) -> name (($#_ <1) && $_[0]->{-tn}) || ($_[0]->{-tn}->{$_[1]}) || (substr($_[1],0,1) eq '-' ? substr($_[1],1) : $_[1]) } sub tfoShow { # Template Field Option '-lblhtml' to Show all details absent # (self, ? input name, ? [detail fields], ? html pattern) my ($s, $n, $d, $h) =@_; sub{ my $x =!$h ? '$_' : ref($h) eq 'CODE' ? &$h(@_) : $h; $_[3] || $_[0]->{-pdta}->{$n||'tfoShow_'} || ($d && !(grep {!$_[0]->{-pout}->{$_}} @$d)) ? $x : ($x .'') } } sub tfoHide { # Template Field Option '-hide' details absent # (self, ? input name) my ($s, $n) =@_; sub {!($_ || $_[0]->{-pdta}->{$n||'tfoShow_'} ||$_[3])} } sub tfdRFD { # Template Field Definition for Record File Directory # self, ? definition my ($s) =@_; return {-fld=>'' ,-flg=>'e' # 'e'dit ,-lbl=>sub{$_[0]->lng(0,'rfafolder')} ,-cmt=>sub{$_[0]->lng(1,'rfafolder')} ,-lblhtml=> sub { return('') if !$s->{-pout}->{-file}; 'cgi->user_agent('MSIE') ? ' style="behavior:url(\'#default#httpFolder\')"' : '') .'>' .($s->{-icons} && $IMG->{'rfafolder'} ? 'cgi->user_agent('MSIE') ? ' style="behavior:url(\'#default#httpFolder\')"' : '') .'/> ' : $s->htmlEscape($s->lng(0,'rfafolder')) .': '); } ,-inp=>{-rfd=>1} ,@_ > 1 ? @_[1..$#_] : () } } sub ttoRVC { # Template Table Option for Record Version Control my $s =$_[0]; my $tn=$s->{-tn}; (-key => $tn->{-key} ,-rvcInsBy => $tn->{-rvcInsBy} ,-rvcInsWhen => $tn->{-rvcInsWhen} ,-rvcUpdBy => $tn->{-rvcUpdBy} ,-rvcUpdWhen => $tn->{-rvcUpdWhen} ,-rvcActPtr => $tn->{-rvcActPtr} ,-rvcVerWhen => $tn->{-rvcVerWhen} ,-rvcChgState => $tn->{-rvcChgState} ,-rvcCkoState => $tn->{-rvcCkoState} ,-rvcDelState => $tn->{-rvcDelState} ,@_ > 1 ? @_[1..$#_] : ()) } sub tvmVersions { # Template for Materialized View of Versions of records # 'versions' materialized view default definition # self, ? fields add, ? definitions add my $s =$_[0]; my $tn=$s->{-tn}; return($tn->{'tvmVersions'}=> {-lbl => sub{$_[0]->lng(0,'tvmVersions')} ,-cmt => sub{$_[0]->lng(1,'tvmVersions')} ,-field => [ {-fld=>'table', -edit=>0, -flg=>'uql'} ,{-fld=>$tn->{-rvcActPtr}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>'id', -edit=>0, -flg=>'uql'} ,{-fld=>$tn->{-rvcInsWhen}, -edit=>0, -flg=>'uq'} ,'' ,{-fld=>$tn->{-rvcInsBy}, -edit=>0, -flg=>'uq'} ,{-fld=>$tn->{-rvcUpdWhen}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>$tn->{-rvcUpdBy}, -edit=>0, -flg=>'uql'} ,{-fld=>$tn->{-rvcState}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>'subject', -edit=>0, -flg=>'uql'} ,{-fld=>'readers', -edit=>0, -flg=>'u'} ,{-fld=>'cargo', -edit=>0, -flg=>'u'} ,ref($_[1]) eq 'ARRAY' ? @{$_[1]} : () ] ,-key => ['table',$tn->{-rvcActPtr},'id'] ,-racReader=> ['readers'] ,-rvcInsBy=> $tn->{-rvcInsBy} ,-rvcUpdBy=> $tn->{-rvcUpdBy} ,-rvcActPtr=> $tn->{-rvcActPtr} ,-query => {-version=>'+'} ,-ixcnd => sub{$_[2]->{'id'}} ,-ixrec => sub{my $m =$_[0]->{-table}->{$_[1]->{-table}}; return( {'table' =>$_[1]->{-table} ,$tn->{-rvcActPtr} =>$m->{-rvcActPtr} && $_[2]->{$m->{-rvcActPtr}} ,'id' =>$_[2]->{'id'} ,$tn->{-rvcInsWhen} =>$m->{-rvcInsWhen} && $_[2]->{$m->{-rvcInsWhen}} ,$tn->{-rvcInsBy} =>$m->{-rvcInsBy} && $_[2]->{$m->{-rvcInsBy}} ,$tn->{-rvcUpdWhen} =>$m->{-rvcUpdWhen} && $_[2]->{$m->{-rvcUpdWhen}} ,$tn->{-rvcUpdBy} =>$m->{-rvcUpdBy} && $_[2]->{$m->{-rvcUpdBy}} ,$tn->{-rvcState} =>$m->{-rvcChgState}&& $_[2]->{$m->{-rvcChgState}->[0]} ,'subject' =>mdeSubj($_[0],$_[2]) ,'readers' =>join(',', map {$_[2]->{$_}||''} grep {$_[2]->{$_}} @{$m->{-racReader}||$_[0]->{-racReader}||[]} , @{$m->{-racWriter}||$_[0]->{-racWriter}||[]}) ,'cargo' =>join("\t",map {$_[2]->{$_}||''} grep {$_[2]->{$_}} keys %{$_[2]}) })} ,-qhref => {-formfld =>'table' ,-key =>['id'] # [['id'=>2]] } ,@_ > 2 ? @_[2..$#_] : () }) } sub tfvVersions { # Template for Field View of Versions of records my ($s, $f, @a) =@_; # (self, ? fields add, ? definitions add | sub{}(self, table, definitions add)) sub{ return('') if ($_[0]->{-pcmd}->{-cmg} eq 'recQBF') || !$_[0]->{-pcmd}->{-table} || !$_[0]->{-pout}->{'id'} || $_[0]->{-pcmd}->{-print}; my $v =$_[0]->{-tn}->{'tvmVersions'}; my $q =($_[0]->{-table}->{$_[0]->{-pcmd}->{-table}}->{-dbd} ||$_[0]->{-dbd}) eq 'dbi'; $v =$_[0]->{-pcmd}->{-table} if $q; my @o =ref($a[0]) eq 'CODE' ? &{$a[0]}($_[0], $v, @a[1..$#a]) : @a; my $u= $q ? {-key=>{$_[0]->{-tn}->{-rvcActPtr}=>$_[0]->{-pout}->{'id'}} ,-version=>1} : {-key=>{$q ? () : ('table'=>$_[0]->{-pcmd}->{-table}) , $_[0]->{-tn}->{-rvcActPtr}=>$_[0]->{-pout}->{'id'}} ,-order=>'-deq' ,-version=>1}; my $h = $u ?($_[0]->cgi->hr() . $_[0]->cgi->a({-title=>$_[0]->lng(1,'recQBF') ,-href=>$_[0]->urlCmd('',-cmd=>'recList' ,-form=>$v ,map { /^-/ ? ('-q' .$' => $u->{$_}) : () } keys %$u)} ,$_[0]->lng(0,'tvmVersions') .':') .' ') : $_[0]->cgi->hr(); local $_[0]->{-uiclass} ='tfvVersions'; local $_[0]->{-uistyle} ='font-size: small' if 0; $_[0]->cgiList('-!h' ,$v ,undef ,{-qhrcol=>1, -qflghtml=>$h, $_[0]->shiftkeys(\@o,'-qhrcol|-qflghtml')} ,{$u ? %$u : () ,-table=>$v ,-order=>$q ? $_[0]->{-tn}->{-rvcUpdWhen} . ' desc' : '-deq' ,-version=>1 ,-data=>[$q ?('id', $_[0]->{-tn}->{-rvcUpdBy}, $_[0]->{-tn}->{-rvcUpdWhen}) :({-fld=>'table', -flg=>'q'} ,{-fld=>'id', -flg=>'q'} ,{-fld=>$_[0]->{-tn}->{-rvcUpdBy}, -flg=>'ql'} ,{-fld=>$_[0]->{-tn}->{-rvcUpdWhen}, -flg=>'ql'}) ,ref($f) eq 'ARRAY' ? @$f : ()] ,-display=>[$_[0]->{-tn}->{-rvcUpdBy}, $_[0]->{-tn}->{-rvcUpdWhen}] ,@o },'; '); '' } } sub tvmHistory { # Template for Materialized View of database History # 'history' materialized view default definition # self, ? fields add, ? definitions add my $s =$_[0]; my $tn=$s->{-tn}; return($tn->{'tvmHistory'}=> {-lbl => sub{$_[0]->lng(0,'tvmHistory')} ,-cmt => sub{$_[0]->lng(1,'tvmHistory')} ,-field => [ {-fld=>$tn->{-rvcInsWhen}, -edit=>0, -flg=>'uq'} ,'' ,{-fld=>$tn->{-rvcInsBy}, -edit=>0, -flg=>'uq'} ,{-fld=>$tn->{-rvcUpdWhen}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>$tn->{-rvcUpdBy}, -edit=>0, -flg=>'uql'} # ,{-fld=>'table', -edit=>0, -flg=>'uq'} # ,'' ,{-fld=>'id', -edit=>0, -flg=>'uq'} ,{-fld=>$tn->{-rvcState}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>$tn->{-rvcActPtr}, -edit=>0, -flg=>'uq'} ,{-fld=>'subject', -edit=>0, -flg=>'uql'} ,{-fld=>'auser', -edit=>0, -flg=>'uql'} ,'' ,{-fld=>'arole', -edit=>0, -flg=>'uql'} ,{-fld=>'puser', -edit=>0, -flg=>'uq'} ,'' ,{-fld=>'prole', -edit=>0, -flg=>'uq'} ,{-fld=>'readers', -edit=>0, -flg=>'u'} ,{-fld=>'cargo', -edit=>0, -flg=>'u'} ,ref($_[1]) eq 'ARRAY' ? @{$_[1]} : () ] ,-key => [$tn->{-rvcUpdWhen},$tn->{-rvcUpdBy},'id'] # ,'table' ,-racReader=> ['readers'] ,-racPrincipal=>['puser','prole'] ,-racActor=> ['auser','arole'] ,-rvcInsBy=> $tn->{-rvcInsBy} ,-rvcUpdBy=> $tn->{-rvcUpdBy} ,-rvcActPtr=> $tn->{-rvcActPtr} ,-ixcnd => sub{$_[2]->{'id'} && $_[2]->{$tn->{-rvcUpdWhen}}} ,-ixrec => sub{ my $m =$_[0]->{-table}->{$_[1]->{-table}}; my $ra = mdeRole($_[0], $m, 'authors'); my $rp = mdeRole($_[0], $m, 'principals','users'); return( {'id' =>$_[1]->{-table} .$RISM1 .$_[2]->{'id'} #'table' =>$_[1]->{-table} #'id' =>$_[2]->{'id'} ,$tn->{-rvcInsWhen} =>$m->{-rvcInsWhen} && $_[2]->{$m->{-rvcInsWhen}} ,$tn->{-rvcInsBy} =>$m->{-rvcInsBy} && $_[2]->{$m->{-rvcInsBy}} ,$tn->{-rvcUpdWhen} =>$m->{-rvcUpdWhen} && $_[2]->{$m->{-rvcUpdWhen}} ,$tn->{-rvcUpdBy} =>$m->{-rvcUpdBy} && $_[2]->{$m->{-rvcUpdBy}} ,$tn->{-rvcState} =>$m->{-rvcChgState}&& $_[2]->{$m->{-rvcChgState}->[0]} ,$tn->{-rvcActPtr} =>$m->{-rvcActPtr} && $_[2]->{$m->{-rvcActPtr}} ,'subject' =>mdeSubj($_[0],$_[2]) ,'auser' =>(!$ra ? undef : !ref($ra) ? $_[2]->{$ra} : @$ra && $ra->[0] ? $_[2]->{$ra->[0]} : undef) || $_[2]->{$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ||''} ,'arole' =>!ref($ra) || $#$ra <1 ? undef : join(',', map {!$_[2]->{$_} ? () : ($_[2]->{$_}) } @$ra[1..$#$ra]) ,'puser' =>(!$rp ? undef : !ref($rp) ? $_[2]->{$rp} : @$rp && $rp->[0] ? $_[2]->{$rp->[0]} : undef) || $_[2]->{$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||''} ,'prole' =>!ref($rp) || $#$rp <1 ? undef : join(',', map {!$_[2]->{$_} ? () : ($_[2]->{$_}) } @$rp[1..$#$rp]) ,'readers' =>join(',', map {$_[2]->{$_}||''} grep {$_[2]->{$_}} @{$m->{-racReader}||$_[0]->{-racReader}||[]} , @{$m->{-racWriter}||$_[0]->{-racWriter}||[]}) ,'cargo' =>join("\t",map {$_[2]->{$_}||''} grep {$_[2]->{$_}} keys %{$_[2]}) })} ,-qhref => {-formfld =>'' # 'table' ,-key =>'id' # ['id'] # [['id'=>3]] } ,-query => {-order =>'-dall'} ,@_ > 2 ? @_[2..$#_] : () }) } sub tvmReferences { # Template for Materialized View of References to records # 'references' materialized view default definition # self, ? fields, ? definition my $s =$_[0]; my $tn=$s->{-tn}; return ($tn->{'tvmReferences'}=> {-lbl => sub{$_[0]->lng(0,'tvmReferences')} ,-cmt => sub{$_[0]->lng(1,'tvmReferences')} ,-field => [ {-fld=>'ir', -edit=>0, -flg=>'uql'} ,'' ,{-fld=>'id', -edit=>0, -flg=>'uql'} ,{-fld=>$tn->{-rvcInsWhen}, -edit=>0, -flg=>'uq'} ,'' ,{-fld=>$tn->{-rvcInsBy}, -edit=>0, -flg=>'uq'} ,{-fld=>$tn->{-rvcUpdWhen}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>$tn->{-rvcUpdBy}, -edit=>0, -flg=>'uq'} ,{-fld=>$tn->{-rvcState}, -edit=>0, -flg=>'uql'} ,'' ,{-fld=>$tn->{-rvcActPtr}, -edit=>0, -flg=>'uq'} ,{-fld=>'subject', -edit=>0, -flg=>'uql'} ,{-fld=>'auser', -edit=>0, -flg=>'uql'} ,'' ,{-fld=>'arole', -edit=>0, -flg=>'uql'} ,{-fld=>'puser', -edit=>0, -flg=>'uq'} ,'' ,{-fld=>'prole', -edit=>0, -flg=>'uq'} ,{-fld=>'readers', -edit=>0, -flg=>'u'} ,ref($_[1]) eq 'ARRAY' ? @{$_[1]} : () ] ,-key => ['ir',$tn->{-rvcUpdWhen},'id'] ,-qhrcol=> 1 ,-racReader=> ['readers'] ,-racPrincipal=>['puser','prole'] ,-racActor=> ['auser','arole'] ,-rvcInsBy=> $tn->{-rvcInsBy} ,-rvcUpdBy=> $tn->{-rvcUpdBy} ,-rvcActPtr=> $tn->{-rvcActPtr} ,-ixcnd => sub{$_[2]->{'id'} && ($_[0]->{-table}->{$_[1]->{-table}}->{-ridRef} ||$_[0]->{-ridRef})} ,-ixrec => sub{ my $s =$_[0]; my $m =$s->{-table}->{$_[1]->{-table}}; my $ir =[]; my $id =$_[1]->{-table} .$RISM1 .$_[2]->{'id'}; foreach my $f (@{$m->{-ridRef} ||$s->{-ridRef}}) { if (!$_[2]->{$f}) { next } elsif ($_[2]->{$f} =~/[\s,.?]/) { my $v =$_[2]->{$f}; while ($v =~/(?:_key=id%3D|_key=)([\w\d]+\Q$RISM1\E[\w\d]+)/i) { push @$ir, $1; $v =$' } } elsif (length($_[2]->{$f}) >$NLEN *3) { next } elsif ($_[2]->{$f} =~/\Q$RISM1\E/) { push @$ir, $_[2]->{$f} } else { push @$ir, $_[1]->{-table} .$RISM1 .$_[2]->{$f} } } return($ir) if !@$ir; my $ra = mdeRole($_[0], $m, 'authors'); my $rp = mdeRole($_[0], $m, 'principals','users'); my $rv = {'id' =>$id # below alike 'tvmHistory' ,$tn->{-rvcInsWhen} =>$m->{-rvcInsWhen} && $_[2]->{$m->{-rvcInsWhen}} ,$tn->{-rvcInsBy} =>$m->{-rvcInsBy} && $_[2]->{$m->{-rvcInsBy}} ,$tn->{-rvcUpdWhen} =>$m->{-rvcUpdWhen} && $_[2]->{$m->{-rvcUpdWhen}} ,$tn->{-rvcUpdBy} =>$m->{-rvcUpdBy} && $_[2]->{$m->{-rvcUpdBy}} ,$tn->{-rvcState} =>$m->{-rvcChgState}&& $_[2]->{$m->{-rvcChgState}->[0]} ,$tn->{-rvcActPtr} =>$m->{-rvcActPtr} && $_[2]->{$m->{-rvcActPtr}} ,'subject' =>mdeSubj($_[0],$_[2]) ,'auser' =>(!$ra ? undef : !ref($ra) ? $_[2]->{$ra} : @$ra && $ra->[0] ? $_[2]->{$ra->[0]} : undef) || $_[2]->{$m->{-rvcUpdBy} ||$_[0]->{-rvcUpdBy} ||''} ,'arole' =>!ref($ra) || $#$ra <1 ? undef : join(',', map {!$_[2]->{$_} ? () : ($_[2]->{$_}) } @$ra[1..$#$ra]) ,'puser' =>(!$rp ? undef : !ref($rp) ? $_[2]->{$rp} : @$rp && $rp->[0] ? $_[2]->{$rp->[0]} : undef) || $_[2]->{$m->{-rvcInsBy} ||$_[0]->{-rvcInsBy} ||''} ,'prole' =>!ref($rp) || $#$rp <1 ? undef : join(',', map {!$_[2]->{$_} ? () : ($_[2]->{$_}) } @$rp[1..$#$rp]) ,'readers' =>join(',', map {$_[2]->{$_}||''} grep {$_[2]->{$_}} @{$m->{-racReader}||$s->{-racReader}||[]} , @{$m->{-racWriter}||$s->{-racWriter}||[]}) }; map {$_ ={'ir'=>$_, %$rv}} @$ir; $ir} ,-qhref => {-formfld =>'' ,-key =>'id' } ,-query => {-order =>'-dall'} ,@_ > 2 ? @_[2..$#_] : () }) } sub tfvReferences { # Template for Field embedded View of References to record my ($s, $f, @a) =@_; # (self, ? fields add, ? definitions add | sub{}(self, table, definitions add)) sub{ return('') if ($_[0]->{-pcmd}->{-cmg} eq 'recQBF') || !$_[0]->{-pcmd}->{-table} || !$_[0]->{-pout}->{'id'}; my $v =$_[0]->{-tn}->{'tvmReferences'}; my $q =(($_[0]->{-table}->{$_[0]->{-pcmd}->{-table}}->{-dbd} ||$_[0]->{-dbd}) eq 'dbi') && !$_[0]->{-table}->{$v}; $v =$_[0]->{-pcmd}->{-table} if $q; my @o =ref($a[0]) eq 'CODE' ? &{$a[0]}($_[0], $v, @a[1..$#a]) : @a; my $qe =$_[0]->{-pout}->{comment} && $_[0]->{-table}->{$v} && $_[0]->{-table}->{$v}->{-mdefld} && $_[0]->{-table}->{$v}->{-mdefld}->{comment}; $qe =$qe && $qe->{-inp} && ($qe->{-inp}->{-htmlopt} || $qe->{-inp}->{-hrefs}) && $_[0]->{-pout}->{comment}; $qe =$qe && ($qe =~/^<(?:where|qwhere)>(.+?)<\/(?:where|qwhere)>/i) && $1; return('') if $q ? !$_[0]->{-table}->{$v}->{-ridRef} : !$_[0]->{-table}->{$v}; my $u =$q ? {-where=>join(' OR ' , $qe ? "($qe)" : () , map { $v .'.' .$_ .'=' .$_[0]->dbi->quote($_[0]->{-pout}->{'id'}) } @{$_[0]->{-table}->{$v}->{-ridRef}} )} : {-key=>{'ir'=>$_[0]->{-pcmd}->{-table} .$RISM1 .$_[0]->{-pout}->{'id'}} ,-order=>'-deq' }; my $h = $_[0]->{-pcmd}->{-print} ? $_[0]->cgi->hr() : $u ?($_[0]->cgi->hr() #. '
' . $_[0]->cgi->a({-title=>$_[0]->lng(1,'recQBF') ,-href=>$_[0]->urlCmd('',-cmd=>'recList' ,-form=>$v ,map { /^-/ ? ('-q' .$' => $u->{$_}) : () } keys %$u)} ,$_[0]->lng(0,'tvmReferences') .':')) #. '
' : $_[0]->cgi->hr(); local $_[0]->{-uiclass} ='tfvReferences'; local $_[0]->{-uistyle} ='font-size: small' if 0; $_[0]->cgiList('-!h' ,$v ,undef ,{-qhrcol=>0, -qflghtml=>$h, $_[0]->shiftkeys(\@o,'-qhrcol|-qflghtml')} ,{$u ? %$u : () ,-table=>$v ,-version=>0 , $q ?( (map {$_[0]->{-table}->{$v}->{-query} && $_[0]->{-table}->{$v}->{-query}->{$_} ? ($_ => $_[0]->{-table}->{$v}->{-query}->{$_}) : () } qw (-display -data -datainc -order -keyord)) # ,-order=>$_[0]->{-tn}->{-rvcUpdWhen} # ,-keyord=>'-dall' ,$_[0]->shiftkeys(\@o,'-display|-data|-datainc|-where|-key|-order|-keyord') ) :(-field=>[{-fld=>'ir', -flg=>'q'} ,{-fld=>'id', -flg=>'q'} ,{-fld=>$_[0]->{-tn}->{-rvcUpdWhen}, -flg=>'ql'} ,{-fld=>$_[0]->{-tn}->{-rvcState}, -flg=>'ql'} ,{-fld=>'subject', -flg=>'ql'} ,{-fld=>'auser', -flg=>'ql'} ,{-fld=>'arole', -flg=>'ql'} ,ref($f) eq 'ARRAY' ? @$f : () ] ,-order=>'-deq' ) ,@o }); '' } } sub tvdIndex { # Template View Definition for Index page my $s =$_[0]; return ($s->{-tn}->{'tvdIndex'}=> {-lbl =>sub{$_[0]->lng(0,'tvdIndex')} ,-cmt =>sub{$_[0]->lng(1,'tvdIndex')} ,-cgcCall =>sub{ my $s =$_[0]; $s->{-fetched} =undef; $s->{-affected} =undef; local @{$s}{-menuchs, -menuchs1} =@{$s}{-menuchs, -menuchs1}; $s->htmlMChs() if !$s->{-menuchs}; $s->output($s->htmlStart(@_[1,2]) # HTTP/HTML/Form headers ,$s->htmlHidden(@_[1,2]) # common hidden fields ,!$s->{-pcmd}->{-print} && $s->htmlMenu(@_[1,2]) # Menu bar ,"\n\n" ); $s->htmlOnLoad("{var e=document.getElementsByTagName('BASE'); if(e && e[0] && (self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length)){e[0].target='_blank'}}"); foreach my $e (($s->{-menuchs} ? @{$s->{-menuchs}} : ()) ,($s->{-menuchs1}? @{$s->{-menuchs1}}: ()) ) { my ($n, $l) = ref($e) ? @$e : ($e, $e); $l ='--- ' .$_[0]->lng(0, 'frmCallNew') .' ---' if !$n && !$l; next if $n eq '-frame'; my ($o, $a) = $n =~/^(.+?)([+&.]+)$/ ? ($1, $2) : ($n, $n); my $l0 =$s->lnglbl($s->{-form}->{$o} ||$s->{-table}->{$o} ||{}, $o)||''; my $l1 =$s->lngcmt($s->{-form}->{$o} ||$s->{-table}->{$o} ||{}, $o)||''; my $ur1=$s->urlCat('','_form'=>$n,'_cmd'=>'frmCall'); my $ur2=$s->{-pcmd}->{-frame} ? $s->urlCat('','_form'=>$n,'_cmd'=>'frmCall','_frame'=>$s->{-pcmd}->{-frame}) : $ur1; $s->output('\n" , '\n" ) } $s->output("\n
' , $n ? $s->cgi->a({-href=>$ur1 ,-title=> $a =~/[+]/ ? $s->lng(1,'frmCallNew') ." '$l0'" : $a =~/[&.]/ ? $s->lng(0,'frmCallOpn') ." '$l0'" : $s->lng(0,'frmCallOpn') ." '$l0'" , $a =~/[+]/ # form ? (-OnClick=>"window.document.open('$ur1', self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length ? '_blank' : '_self','',false); return(false)" # or "this.target = self.name.match(/^(?:TOP|BOTTOM)\$/) || document.getElementsByName('_frame').length ? '_blank' : '_self'; return(true)"; ) : (-target=>'_self' # list ,-OnClick=>"window.document.open('$ur2', self.name=='TOP' ? '_self': self.name=='BOTTOM' ? 'TOP' : '_self','',false); return(false)" # or "this.target = self.name=='TOP' ? '_self' : self.name=='BOTTOM' ? 'TOP' : '_self'; return(true)"; ) } ,(!$s->{-icons} ? '' : '') . $s->htmlEscape($l0)) : $s->htmlEscape($l) , " ' , $s->htmlEscape( !$l1 || $l1 ne $l0 ? $l1||'' : 1 ? $l1||'' : $a =~/[+]/ ? $s->lng(0,'frmCallNew') ." '$l0'" : $a =~/[&.]/ ? $s->lng(0,'frmCallOpn') ." '$l0'" : $s->lng(0,'frmCallOpn') ." '$l0'" ) , "
\n"); # $s->recCommit(); $s->cgiFooter() if !$s->{-pcmd}->{-print}; $s->output($s->htmlEnd()); $s->end(); } ,@_ > 1 ? @_[1..$#_] : () }) } sub tvdFTQuery { # Template View Definition for Full-Text Query my $s =$_[0]; return ($s->{-tn}->{'tvdFTQuery'}=> {-lbl =>sub{$_[0]->lng(0,'tvdFTQuery')} ,-cmt =>sub{$_[0]->lng(1,'tvdFTQuery')} ,-cgcCall =>sub{ my $s =$_[0]; my $g =$s->cgi(); $s->{-fetched} =0; $s->{-affected} =undef; $s->{-pcmd}->{-cmd} =$s->{-pcmd}->{-cmg} ='recQBF'; $s->output($s->htmlStart(@_[1,2]) # HTTP/HTML/Form headers ,$s->htmlHidden(@_[1,2]) # common hidden fields ,!$s->{-pcmd}->{-print} && $s->htmlMenu(@_[1,2]) # Menu bar ,"\n" ); $s->die('Microsoft IIS required') if $ENV{SERVER_SOFTWARE} !~/IIS/; $g->param('_qftwhere' , defined($g->param('_qftwhere')) && ($g->param('_qftwhere') ne '') ? $g->param('_qftwhere') : defined($g->param('_qftext')) && ($g->param('_qftext') ne '') ? $g->param('_qftext') : ''); $s->output($g->textfield(-name=>'_qftwhere', -size=>70, -title=>$s->lng(1,'-qftwhere')) , '
' , $g->popup_menu(-name=>'_qftord' ,-values=>['write','hitcount','vpath','docauthor'] ,-labels=>{ 'write' =>'Chronologically' ,'hitcount' =>'Ranked' ,'vpath' =>'by Name' ,'docauthor' =>'by Author' } ,-default=>'write') , $g->popup_menu(-name=>'_qlimit' ,-values=>['',128,256,512,1024,2048,4096] ,-labels=>{ '' =>"$LIMRS default" ,128 =>'128 max' ,256 =>'256 max' ,512 =>'512 max' ,1024=>'1024 max' ,2048=>'2048 max' ,4096=>'4096 max' } ,-default=>$LIMRS) , $g->submit(-name =>'tvdFTQuery_' ,-value=>$s->lng(0,'recList') ,-title=>$s->lng(1,'recList')) , '' && $g->a({-href=> -e ($ENV{windir} .'/help/ix/htm/ixqrylan.htm') ? '/help/microsoft/windows/ix/htm/ixqrylan.htm' : '/help/microsoft/windows/isconcepts.chm' # .'::/ismain-concepts_30.htm' }, '?') , "
\n"); if ($g->param('_qftwhere') ne '') { eval('use Win32::OLE; Win32::OLE->Option("Warn"=>0)'); Win32::OLE->Initialize(); # Win32::OLE->Initialize(&Win32::OLE::COINIT_OLEINITIALIZE); # Search MSDN for 'ixsso.Query' my $oq =Win32::OLE->CreateObject("ixsso.Query"); !$oq && $s->die("'OLE->CreateObject(ixsso.Query)' failed '$!'/'$@'/" .Win32::OLE->LastError); my $ou =Win32::OLE->CreateObject("ixsso.util"); !$oq && $s->die("'OLE->CreateObject(ixsso.util)' failed '$!'/'$@'/" .Win32::OLE->LastError); my $qs =[]; my $qt =[]; $oq->{Query} =$g->param('_qftwhere') =~/^(@\w|\{\s*prop\s+name\s+=)/i ? $g->param('_qftwhere') : ('@contents ' .$g->param('_qftwhere')); $oq->{Catalog} ='Web'; $oq->{MaxRecords} =$g->param('_qlimit') ||$LIMRS; $oq->{MaxRecords} =4096 if $oq->{MaxRecords} >4096; $oq->{SortBy} =$g->param('_qftord') ||'write'; $oq->{SortBy} .=$oq->{SortBy} =~/^(write|hitcount)$/i ? '[d],docauthor[a]' : '[a],write[d]'; $oq->{Columns} ='vpath,path,filename,hitcount,write,doctitle,docauthor,characterization'; $oq->{LocaleID} =1049; # ru my $ol =eval {$oq->CreateRecordset('sequential')}; # 'nonsequential' !$oq && $s->die("'OLE->CreateRecordset(sequential)' failed '$!'/'$@'/" .Win32::OLE->LastError); $s->output('No records found') if $ol->{EOF}; my ($rcf, $rct, $rcd) =(0, 0, 0); while (!$ol->{EOF}) { my $vp =$ol->{vPath}->{Value}; $rcf +=1; if (!$vp) { $rct +=1; } if ($vp) { $rcd +=1; my $vt =$g->escapeHTML($ol->{DocTitle}->{Value}); $vt = ($vt ? '$vt' .'  ' : '') . '(' .$g->escapeHTML($ol->{DocAuthor}->{Value}) .')' if $ol->{DocAuthor}->{Value}; $vt = ($vt ? $vt .'   (' : '') . $g->escapeHTML($vp) .')'; $s->output($g->a({-href=>$vp||$ol->{Path}->{Value} ,-title=>$ol->{HitCount}->{Value} .': ' .$ol->{Path}->{Value}} , $vt) , $ol->{Characterization}->{Value} ? '
' .$g->escapeHTML($ol->{Characterization}->{Value}) : '' , "

\n"); } if (!eval {$ol->MoveNext; 1}) { $s->output('Bad query'); last } } Win32::OLE->FreeUnusedLibraries; # Win32::OLE->Uninitialize; $s->{-fetched} =$rcd; $s->{-affected} =$rcf; $s->logRec('FTQuery',-fetched=>$rcd, -found=>$rcf, -vpathgen=>$rct, -max=>($oq->{MaxRecords}||'undef')); } else { $s->output('Enter query condition') } $s->{-pcmd}->{-cmd} =$s->{-pcmd}->{-cmg} ='recList'; $s->cgiFooter() if !$s->{-pcmd}->{-print}; $s->output($s->htmlEnd()); $s->end(); } ,@_ > 1 ? @_[1..$#_] : ()}) } sub ttsAll { # Template Tables Set of All generally used views return( # - to add to '-table' $_[0]->tvmVersions() ,$_[0]->tvmHistory() ,$_[0]->tvmReferences() ) } sub tfsAll { # Template Fields Set for All generally used fields return( # - to add to '-field' $_[0]->tfdRFD() ,"\f" ,$_[0]->tfvVersions() ,$_[0]->tfvReferences() ) } ######################################################### # File Handle Object ######################################################### package DBIx::Web::FileHandle; use strict; use Symbol; use Fcntl qw(:DEFAULT :flock :seek :mode); sub new { my ($c, %o) =@_; my $s ={-name =>'' # file name ,-mode =>'<' # file open mode ,-parent=>undef # parent object ,-handle=>undef # Symbol::gensym on file open ,-lock =>LOCK_UN # lock level ,-lcks =>{} # locks # ,-new =>undef # new file created # ,-buf =>undef # file contents from 'loadXX' calls # ,-ret =>undef # data to return, for external programming }; foreach my $k (keys(%o)) {$s->{$k} =$o{$k}} bless $s, $c; $s->open() if defined($s->{-name}) && $s->{-name} ne ''; $s } sub set { return(keys(%{$_[0]})) if scalar(@_) ==1; return($_[0]->{$_[1]}) if scalar(@_) ==2; my ($s, %o) =@_; foreach my $k (keys(%o)) {$s->{$k} =$o{$k}}; $s } sub parent { $_[0]->{-parent} } sub open { my $s =shift; if (!@_) {} elsif ($_[0] =~/^-(name|mode)$/) {$s->set(@_)} else {foreach my $k ('-mode','-name') {$s->{$k} =shift if defined($_[0])}} $s->{-new} =!-e $s->{-name}; $s->{-lcks}={}; if (!CORE::open($s->{-handle} =Symbol::gensym, $s->{-mode}, $s->{-name})) { $s->{-handle} =undef; return(&{$s->{-parent} ? $s->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("File: open('" .($s->{-mode}||'') ."','" .($s->{-name}||'') ."') -> $!" .($s->{-parent} && $s->{-parent}->{-ermd} ||'') ) ||undef) } $s } sub opent { return($_[0]) if $_[0]->{-handle}; $_[0]->open() || return(undef); $_[0]->lock($_[0]->{-lock}) if $_[0]->{-lock} ne LOCK_UN; $_[0] } sub binmode { CORE::binmode($_[0]->{-handle}); $_[0] } sub close { return($_[0]) if !$_[0]->{-handle}; $_[0]->lock(LOCK_UN |LOCK_NB) if $_[0]->{-lock} ne LOCK_UN; $_[0]->{-lcks}={}; CORE::close($_[0]->{-handle}); $_[0]->{-handle} =undef; $_[0] } sub destroy { eval{$_[0]->close()} if $_[0]->{-handle}; $_[0]->{-parent} =undef; $_[0] } sub DESTROY { destroy(@_) } sub lock { # ?lock value, ?lock key # LOCK_SH ==1; LOCK_EX ==2, or LOCK_UN ==8, LOCK_NB ==4 return($_[0]->{-lock}) if !defined($_[1]); my $l =!$_[1] ? LOCK_UN : $_[1]; my $lv=$l | LOCK_NB ^ LOCK_NB; $_[0]->opent() if !$_[0]->{-handle}; if ($_[0]->{-lock} ne $lv) { if ($lv eq LOCK_UN) { CORE::flock($_[0]->{-handle}, $_[0]->{-lock} =LOCK_UN); if (!defined($_[2])) { $_[0]->{-lcks} ={} } else { delete $_[0]->{-lcks}->{$_[2]} } $l =0; map {$l =$_ if $l <$_} values %{$_[0]->{-lcks}}; $_[0]->{-lock} =$lv =$l if $l && CORE::flock($_[0]->{-handle}, $l); } else { CORE::flock($_[0]->{-handle}, $_[0]->{-lock} =LOCK_UN); $_[0]->{-lock} =$lv if CORE::flock($_[0]->{-handle}, $l); } } if (!defined($_[2])) { $_[0]->{-lcks} ={} } elsif ($lv eq LOCK_UN || $_[0]->{-lock} ne $lv ) { delete $_[0]->{-lcks}->{$_[2]} } else { $_[0]->{-lcks}->{$_[2]} =$lv } $_[0]->{-lock} eq $lv ? $_[0] : undef } sub seek { # WHENCE: 0 - SEEK_SET - to set the new position to POSITION, # 1 - SEEK_CUR - to set it to the current position plus POSITION, # 2 - SEEK_END - to set it to EOF plus POSITION return(CORE::tell($_[0]->{-handle})) if @_ <2; CORE::seek($_[0]->{-handle}, $_[1], defined($_[2]) ?$_[2] :SEEK_SET) ? $_[0] : (&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("File: seek('" .($_[0]->{-name}||'') ."') -> $!" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef) } sub read { my $r =CORE::read($_[0]->{-handle}, $_[1], $_[2], $_[3]||0); return(&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("File: read('" .($_[0]->{-name}||'') ."') -> $!" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef) if !defined($r); $r } sub readline { CORE::readline($_[0]->{-handle}) } sub print { my $s =shift; my $h =$s->{-handle}; return(&{$s->{-parent} ? $s->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("File: print('" .($s->{-name}||'') ."') -> $!" .($s->{-parent} && $s->{-parent}->{-ermd} ||'') ) ||undef) if !CORE::print $h @_; $s } sub load { my $b =''; my $l =$_[0]->{-lock}; $_[0]->opent() if !$_[0]->{-handle}; $_[0]->lock(LOCK_SH) if $l eq LOCK_UN; $_[0]->{-buf} =defined($_[0]->seek(0)->read($b, -s $_[0]->{-handle})) ? $b : undef; $_[0]->lock(LOCK_UN) if $l eq LOCK_UN; defined($_[0]->{-buf}) ? $_[0] : undef; } sub store { my $s =shift; my $l =$s->{-lock}; $s->opent() if !$s->{-handle}; $s->lock(LOCK_EX) if $l eq LOCK_UN; $s->select(sub{$|=1}); my $r =$s->seek(0)->print(@_ ? @_ : $s->{-buf}); # !!! simple, may be unsafe truncate($s->{-handle}, CORE::tell($s->{-handle})); $s->lock(LOCK_UN) if $l eq LOCK_UN; $r } sub select { my $r; ref($_[1]) eq 'CODE' ? select((select($_[0]->{-handle}), $r =&{$_[1]}(@_))[0]) && $r : select($_[0]->{-handle}) } ######################################################### # DB_File ISAM Handle Object ######################################################### package DBIx::Web::dbmHandle; use strict; use Symbol; use Fcntl qw(:DEFAULT :flock :seek :mode); # my $NLEN =20; # length to pad left index numbers sub new { my ($c, %o) =@_; my $s ={-name =>'' # file name ,-mode =>O_CREAT|O_RDWR ,-parent=>undef # parent object #,-table =>undef # data table description ,-handle=>undef # tied object ref #,-data =>undef # tied data hash ref #,-new =>undef # new file created #,-fh =>undef # file handle ,-lock =>LOCK_UN # lock level ,-lcks =>{} # locks ,-pair =>[] # current key/value }; foreach my $k (keys(%o)) {$s->{$k} =$o{$k}} bless $s, $c; $s->open if defined($s->{-name}) && $s->{-name} ne ''; $s } sub set { return(keys(%{$_[0]})) if scalar(@_) ==1; return($_[0]->{$_[1]}) if scalar(@_) ==2; my ($s, %o) =@_; foreach my $k (keys(%o)) {$s->{$k} =$o{$k}}; $s } sub parent { $_[0]->{-parent} } sub open { eval('use DB_File'); my $s =shift; if (!@_) {} elsif ($_[0] =~/^-(name|mode)$/) {$s->set(@_)} else {foreach my $k ('-mode','-name') {$s->{$k} =shift if defined($_[0])}} my %hash; my $par =eval('new DB_File::BTREEINFO'); if ($s->{-table} && $s->{-table}->{-keycmp}) { my $t =$s->{-table}->{-keycmp}; $par->{'compare'} =sub{&t($s, map {[map {m/^ *(.*)$/ ? $1 : $_} split /\x00/, $_]} @_)} # see keyUnescape below } $s->{-new} =!-e $s->{-name}; $s->{-handle} =tie %hash, 'DB_File', $s->{-name}, $s->{-mode}, 0x666, $par; $s->{-data} =\%hash; $s->{-lcks} ={}; if (!$s->{-handle}) { $s->{-handle} =$s->{-data} =undef; return(&{$s->{-parent} ? $s->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("DBFile: open('" .($s->{-mode}||'') ."','" .($s->{-name}||'') ."') -> $!" .($s->{-parent} && $s->{-parent}->{-ermd} ||'') ) ||undef) } $s } sub opent { return($_[0]) if $_[0]->{-handle}; $_[0]->open || return(undef); $_[0]->lock($_[0]->{-lock}) if $_[0]->{-lock} ne LOCK_UN; $_[0] } sub close { return($_[0]) if !$_[0]->{-handle}; $_[0]->lock(LOCK_UN) if $_[0]->{-lock} ne LOCK_UN; close($_[0]->{-fh}) if $_[0]->{-fh}; my $h =$_[0]->{-data}; $_[0]->{-data} =undef; $_[0]->{-handle} =undef; $_[0]->{-fh} =undef; $_[0]->{-lcks} ={}; #eval {untie %$h}; # warning if another reference exists $_[0] } sub sync { return($_[0]) if !$_[0]->{-handle}; $_[0]->{-handle}->sync(); } sub destroy { eval{$_[0]->close} if $_[0]->{-handle}; $_[0]->{-parent} =undef; $_[0]->{-table} =undef; $_[0] } sub DESTROY { destroy(@_) } sub lock { # lock value, ?lock key # LOCK_SH ==1; LOCK_EX ==2, or LOCK_UN ==8, LOCK_NB ==4 return($_[0]->{-lock}) if !defined($_[1]); my $l =!$_[1] ? LOCK_UN : $_[1]; my $lv=$l | LOCK_NB ^ LOCK_NB; if (!$_[0]->{-fh} && !CORE::open($_[0]->{-fh} =Symbol::gensym, '+<&=' .$_[0]->{-handle}->fd)) { $_[0]->{-fh} =undef; return(&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("DBFile: open('+<&=','" .($_[0]->{-name}||'') ."') -> $!" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef) } if ($_[0]->{-lock} ne $lv) { $_[0]->{-handle}->sync; if ($lv eq LOCK_UN) { CORE::flock($_[0]->{-fh}, $_[0]->{-lock} =LOCK_UN); if (!defined($_[2])) { $_[0]->{-lcks} ={} } else { delete $_[0]->{-lcks}->{$_[2]} } $l =0; map {$l =$_ if $l <$_} values %{$_[0]->{-lcks}}; $_[0]->{-lock} =$lv =$l if $l && CORE::flock($_[0]->{-fh}, $l); } else { CORE::flock($_[0]->{-fh}, $_[0]->{-lock} =LOCK_UN); $_[0]->{-lock} =$lv if CORE::flock($_[0]->{-fh}, $l); } $_[0]->{-handle}->sync; } if (!defined($_[2])) { $_[0]->{-lcks} ={} } elsif ($lv eq LOCK_UN || $_[0]->{-lock} ne $lv ) { delete $_[0]->{-lcks}->{$_[2]} } else { $_[0]->{-lcks}->{$_[2]} =$lv } $_[0]->{-lock} eq $lv ? $_[0] : undef } sub keyGet { return($_[0]->{-pair}->[1]) if @_ <2; my $v; $_[0]->{-handle}->get($_[1], $v) ? undef : $v } sub keyPut { $_[0]->{-handle}->put($_[1], $_[$#_]) ? (&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("DBFile: keyPut('" .($_[0]->{-name}||'') ."','" .$_[1] ."') -> $!" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef) : (@_ >3) && ($_[1] ne $_[2]) && $_[0]->{-handle}->del($_[2]) ? (&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("DBFile: keyDel('" .($_[0]->{-name}||'') ."','" .$_[2] ."') -> $!" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef) : $_[$#_] } sub keyDel { $_[0]->{-handle}->del(@_[1..$#_]) ? undef : $_[0] } sub keyFind { my ($s, $k, $v) =@_; $s->{-handle}->seq($k, $v, R_CURSOR()) ? undef : (@{$s->{-pair}}[1,0]=($k,$v))[0] } sub keyFirst { my ($s, $k, $v) =@_; $s->{-handle}->seq($k, $v, R_FIRST()) ? undef : (@{$s->{-pair}}[1,0]=($k,$v))[0] } sub keyLast { my ($s, $k, $v) =@_; $s->{-handle}->seq($k, $v, R_LAST()) ? undef : (@{$s->{-pair}}[1,0]=($k,$v))[0] } sub keyPrev { my ($s, $k, $v) =@_; $s->{-handle}->seq($k, $v, R_PREV()) ? undef : (@{$s->{-pair}}[1,0]=($k,$v))[0] } sub keyNext { my ($s, $k, $v) =@_; $s->{-handle}->seq($k, $v, R_NEXT()) ? undef : (@{$s->{-pair}}[1,0]=($k,$v))[0] } sub krEscape { join "\x00" ,map { my $v =$_; return('') if !defined($v); # !!! lost undefined values $v =~s/^ *(.*?) *$/$1/; # !!! lost extra blanks # $v =~s/\000/\\000/g; # !!! key compare problem $v =~s/\000//g; # !!! lost \x00 chars $v =' ' x ($NLEN -length($v)) .$v # !!! $NLEN-sign numbers if $v =~/^[\d .,]+$/m && length($v) <$NLEN; $v } @{$_[1]} } sub krEscapeMv { my $r =['']; foreach my $v (@{$_[1]}) { if (!ref($v)) { $v ='' if !defined($v); # !!! lost undefined values $v =~s/^ *(.*?) *$/$1/; # !!! lost extra blanks $v =~s/\000//g; # !!! lost \x00 chars $v =' ' x ($NLEN -length($v)) .$v # !!! $NLEN-sign numbers if $v =~/^[\d .,]+$/m && length($v) <$NLEN; map {$_ .=$v ."\x00"} @$r } elsif (ref($v) eq 'ARRAY') { my $r0 =$r; $r =[]; my $a =$v; foreach my $k (@$a) { foreach my $e (@{krEscapeMv($_[0],$k)}) { foreach my $v (@$r0) { push @$r, "$v$e\x00" } } } } elsif (ref($v) eq 'HASH') { my $r0 =$r; $r =[]; my $h =$v; foreach my $k (keys %$h) { my $v =$k; $v ='' if !defined($v); # !!! lost undefined values $v =~s/^ *(.*?) *$/$1/; # !!! lost extra blanks $v =~s/\000//g; # !!! lost \x00 chars foreach my $e (@{krEscapeMv($_[0], $h->{$k})}) { foreach my $v (@$r0) { push @$r, $v . "$k=>$e\x00" } } } } } map {chop $_} @$r; $r } sub krUnescape { [map {m/^ *(.*)$/ ? $1 : $_} split /\x00/, $_[$#_]] } sub klUnescape { map {m/^ *(.*)$/ ? $1 : $_} split /\x00/, $_[$#_] } sub hrEscape { # freeze($_[$#_]) ref($_[$#_]) ne 'ARRAY' ? '{' .join(',' , map { my ($k, $v) =($_, $_[$#_]->{$_}); $k =~s/([,=%\\\]\[\{\}])/sprintf("\\x%02x",ord($1))/eg; if (ref($v)) {$v =hrEscape($v)} else {$v =~s/([,=%\\\]\[\{\}])/sprintf("\\x%02x",ord($1))/eg} "$k=$v" } grep {defined($_[$#_]->{$_}) } keys %{$_[$#_]}) .'}' : '[' .join(',' , map { my $k =$_; $k =~s/([,=%\\\]\[\{\}])/sprintf("\\x%02x",ord($1))/eg; $k } grep {defined($_) } @{$_[$#_]}) .']' } sub hrUnescape { # thaw($_[$#_]) $_[$#_] =~/^\{/ ? {hlUnescape(@_)} : $_[$#_] =~/^\[/ ? [hlUnescape(@_)] : $_[$#_] } sub hlUnescape { # %{thaw($_[$#_])} if (ref($_[$#_])) { my $k; while ($k =each %{$_[$#_]}) {$_[$#_]->{$k} =undef}; $k =undef; foreach (split / *[,=] */, ($_[$#_-1] =~/^[\{\[]/ ? substr($_[$#_-1], 1, -1) : $_[$#_-1])) { /^\[\{\[]/ ? hrUnescape($_[0], $_) : s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg; if ($k) {$_[$#_]->{$k} =$_; $k =undef} else {$k =$_} } $_[$#_]; } else { $_[$#_] =~/^[\{\[]/ ? (map { /^\[\{\[]/ ? hrUnescape($_[0], $_) : s/\\x([0-9a-fA-F]{2})/chr hex($1)/eg; } split / *[,=] */, substr($_[$#_], 1, -1)) : ($_[$#_]) } } sub keGet { return($_[0]->{-pair}->[1]) if @_ <2; my $v; $_[0]->{-handle}->get(krEscape($_[0], $_[1]), $v) ? undef : hrUnescape($v) } sub kePut { my $r =0; my $d =hrEscape($_[$#_]); if (@_ >3) { my $kn =krEscapeMv($_[0], $_[1]); my $ko =krEscapeMv($_[0], $_[2]); foreach my $k (@$kn) { $_[0]->{-handle}->put($k, $d) && (&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("DBFile: kePut('" .($_[0]->{-name}||'') ."','$k') -> '$!'" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef); $r +=1; } foreach my $k (grep {my $v =$_; !grep {$v eq $_} @$kn} @$ko) { $_[0]->{-handle}->del($k) } } else { foreach my $k (@{krEscapeMv($_[0], $_[1])}) { $_[0]->{-handle}->put($k, $d) && (&{$_[0]->{-parent} ? $_[0]->{-parent}->{-die} : $DBIx::Web::LNG->{-die}} ("DBFile: kePut('" .($_[0]->{-name}||'') ."','$k') -> '$!'" .($_[0]->{-parent} && $_[0]->{-parent}->{-ermd} ||'') ) ||undef); $r +=1; } } $r } sub keDel { my $r =0; foreach my $k (@{krEscapeMv($_[0], $_[1])}) { $_[0]->{-handle}->del($k) ||($r +=1) } $r ||undef } sub keSeek { my ($s, $flg, $sca, $subf, $subw) =@_; # dir/cmp, keyArray, subFilter, subEval my $p =$s->parent; my $val =undef; my $dbh =$s->{-handle}; my $dbs =0; my @kds =map {!ref($_) ? $_ : $_->[0]} @{$s->{-table}->{-key}} # , '_rid' if $s->{-table} && $s->{-table}->{-key}; my ($r, $k) =({}, []); # record hash & key array refs my $ca =0; my $subr=sub{undef}; foreach my $sck (@{$s->krEscapeMv($sca)}) { my $key =$sck; my $scl =length($sck); if ($flg =~/^-*[af]eq/i) { # forward eq $dbs =$dbh->seq($key, $val, R_CURSOR()); $subr=sub{do { return(undef) unless !$dbs && (defined($key) ? $sck eq substr($key, 0, $scl) : 0); $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_NEXT()); } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[af]g[te]/i) { # forward g[te] $key .="\x01" if $flg =~/gt$/i; $dbs =$dbh->seq($key, $val, R_CURSOR()); $subr=sub{do { return(undef) unless !$dbs; $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_NEXT()); } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[af]l[te]/i) { # forward l[te] $dbs =$dbh->seq($key, $val, R_FIRST()); $subr=sub{do { return(undef) unless !$dbs && (!defined($key) ? 0 : $flg=~/lt$/i ? $sck lt substr($key, 0, $scl) : $sck le substr($key, 0, $scl)); $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_NEXT()); } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[af]all/i) { # forward all $dbs =$dbh->seq($key, $val, R_FIRST()); $subr=sub{do { return(undef) unless !$dbs; $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_NEXT()); } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[bd]eq/i) { # backward eq $key .="\x01"; $dbs =$dbh->seq($key, $val, R_CURSOR()); $dbs =$dbh->seq($key, $val, R_PREV()); $subr=sub{do { return(undef) unless !$dbs && (defined($key) ? $sck eq substr($key, 0, $scl) : 0); $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_PREV()) } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[bd]l[te]/i) { # backward l[te] $key .="\x01" if $flg =~/le$/i; $dbs =$dbh->seq($key, $val, R_CURSOR()); $dbs =$dbh->seq($key, $val, R_PREV()); $subr=sub{do { return(undef) unless !$dbs; $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_PREV()) } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[bd]g[te]/i) { # backward g[te] $dbs =$dbh->seq($key, $val, R_LAST()); $subr=sub{do { return(undef) unless !$dbs && (!defined($key) ? 0 : $flg=~/gt$/i ? $sck gt substr($key, 0, $scl) : $sck ge substr($key, 0, $scl)); $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_PREV()) } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } elsif ($flg =~/^-*[bd]all/i) { # backward all $dbs =$dbh->seq($key, $val, R_LAST()); $subr=sub{do { return(undef) unless !$dbs; $r =hlUnescape($s, $val, $r); @$k=klUnescape($s, $key); @$r{@kds}=@{$k} if @kds && !@$r{@kds}; $dbs =$dbh->seq($key, $val, R_PREV()) } while ($subf && !&$subf($s, $k, $r)) || ($subw && ++$ca && &$subw($s, $k, $r)); $r } } } $subr =DBIx::Web::dbmCursor->new($subr, -rec=>$r, -key=>$k); if ($subw) {$subr->call; $subr =$ca}; $subr } sub keScan { &{shift->parent->{-die}}("DBFile: 'keScan' not implemented yet!") } ######################################################### # Condition code block object, use isa($object,'CODE') ! ######################################################### package DBIx::Web::ccbHandle; use strict; sub new { my ($c, $e) =@_; if (!ref($e)) { # string to safe evaluate my $c =$e; my $m =eval('use Safe; Safe->new()'); eval{local $^W =0; $m->permit_only(qw(:default :base_core :browse))}; eval{local $^W =0; $m->share('@_', '$DBIx::Web::SELF')}; my $o =$DBIx::Web::SELF; $e =sub{ local ($DBIx::Web::SELF, $^W) =($o, 0); $m->reval($c)}; } bless $e, $c; $e } sub call { &{$_[0]}(@_[1..$#_]) } sub fetch{ &{$_[0]}(@_[1..$#_]) } sub eval { CORE::eval{&{$_[0]}(@_[1..$#_])} } ######################################################### # DBM Cursor object ######################################################### package DBIx::Web::dbmCursor; use strict; sub new { my ($c, $e) =@_; my $s={''=>$e, -rfl=>undef, @_[2..$#_]}; # -rec=>{}, -key=>[], -rfr=>[]; -query=>{} bless $s, $c; $s } sub setcols { $_[0]->{NAME_db} =[map {!ref($_) ? $_ : ref($_) ne 'HASH' ? $_->[0] : (defined($_->{-expr}) ? $_->{-expr} : $_->{-fld})} ref($_[1]) ? @{$_[1]} : @_[1..$#_]]; $_[0]->{NAME} =[map {!ref($_) ? $_ : ref($_) ne 'HASH' ? $_->[1] : $_->{-fld}} ref($_[1]) ? @{$_[1]} : @_[1..$#_]]; $_[0]->{-rfr} =[map {$_[0]->{-rec}->{$_} =undef if !exists($_[0]->{-rec}->{$_}); \($_[0]->{-rec}->{$_}) } @{$_[0]->{NAME_db}}] if $_[0]->{-rec}; $_[0]->{-rfl} =[]; # record fields list $_[0] } sub call { &{$_[0]->{''}}(@_[1..$#_]) } sub eval { CORE::eval{&{$_[0]->{''}}(@_[1..$#_])} } sub fetch { my $v =&{$_[0]->{''}}(@_[1..$#_]); if ($v) {@{$_[0]->{-rfl}} =map {$$_} @{$_[0]->{-rfr}}; $_[0]->{-rfl}} else {@{$_[0]->{-rfl}} =(); undef} } sub fetchrow_arrayref { my $v =&{$_[0]->{''}}(@_[1..$#_]); if ($v) {@{$_[0]->{-rfl}} =@${v}{@{$_[0]->{NAME_db}}}; $_[0]->{-rfl}} else {@{$_[0]->{-rfl}} =(); undef} } sub fetchrow_hashref { $_[0]->{-rec} =&{$_[0]->{''}}(@_[1..$#_]); } sub finish { $_[0]->{''} =undef; } sub close { $_[0]->{''} =undef; } ######################################################### # DBI Cursor object implementing filtering sub{} ######################################################### package DBIx::Web::dbiCursor; use strict; use vars qw($AUTOLOAD); sub new { my ($c, $i) =@_; my $s={''=>$i, @_[2..$#_]}; # -rec=>{}, -rfr=>[], -flt=>sub{}; -query=>{} eval{$s->{'NAME'}=$s->{''}->{'NAME'}} if ref($s->{''}); bless $s, $c; $s } sub fetch { return($_[0]->{''}->fetch(@_[1..$#_])) if !$_[0]->{-flt}; my ($r, $k); while (1) { while ($k = each %{$_[0]->{-rec}}) {$_[0]->{-rec}->{$k} =undef}; $r =$_[0]->{''}->fetch(@_[1..$#_]); last if !$r || !$_[0]->{-flt} || &{$_[0]->{-flt}}($_[0],undef,$_[0]->{-rec}) } $r } sub fetchrow_arrayref { return($_[0]->{''}->fetchrow_arrayref(@_[1..$#_])) if !$_[0]->{-flt}; my ($r, $k); while (1) { while ($k = each %{$_[0]->{-rec}}) {$_[0]->{-rec}->{$k} =undef}; $r =$_[0]->{''}->fetchrow_arrayref(@_[1..$#_]); last if !$r || !$_[0]->{-flt} || &{$_[0]->{-flt}}($_[0],undef,$_[0]->{-rec}) } $r } sub fetchrow_hashref { return($_[0]->{''}->fetchrow_hashref(@_[1..$#_])) if !$_[0]->{-flt}; my ($r, $k); while (1) { while ($k = each %{$_[0]->{-rec}}) {$_[0]->{-rec}->{$k} =undef}; $r =$_[0]->{''}->fetchrow_hashref(@_[1..$#_]); last if !$r || !$_[0]->{-flt} || &{$_[0]->{-flt}}($_[0],undef,$_[0]->{-rec}) } $r } sub finish { $_[0]->{''}->finish(@_[1..$#_]) } sub close { eval {$_[0]->{''}->finish(@_[1..$#_])}; $_[0]->{''}=undef; } sub AUTOLOAD { my $m =substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); confess("!object in AUTOLOAD of $AUTOLOAD") if !ref($_[0]); $_[0]->{''}->$m(@_[1..$#_]) } ######################################################### # UINION cursor/container operation cursor ######################################################### package DBIx::Web::dbcUnion; use strict; sub new { # UNION peration cursor my $c =shift; # (option=>value,...{hash data} || [array data] || cursor,...) my $s={ -i =>[] # cursors or arrays, hashes are sorted to arrays ,-j =>[] # indexes of arrays ,-d =>[] # data buffers ,-asc =>1 # ascending order ,-lc =>1 # lowercase order compare ,-rl =>undef # right to left compare (for internal/external values) ,-all =>undef # non unique, records may be duplicated ,-rec =>{} # out record as hash ,-rfr =>[] # out record as array ,0 =>undef # inited mark ,'NAME' =>undef # column names, may be obtained from cursor or not used }; while (defined($_[0])) { if (!ref($_[0])) { $s->{shift(@_)} =shift(@_) } else { push @{$s->{-i}}, shift(@_) } } if (!$s->{'NAME'}) { foreach my $e (@{$s->{-i}}) { next if !$e || (ref($e) =~/^(?:ARRAY|HASH)$/); eval{$s->{'NAME'}=$e->{'NAME'} if ref($e->{'NAME'})}; last if $s->{'NAME'} } } if (ref($s->{'NAME'})) {eval{ @{$s->{-rec}}[@{$s->{NAME}}] =(); @{$s->{-rfr}} =map {\($s->{-rec}->{$_})} @{$s->{NAME}}; }} bless $s, $c; $s } sub fetch { my $s =$_[0]; return(undef) if !defined($s->{-i}) || !defined($s->{-rfr}); if (!$s->{0}) { # init processing $s->{0} =1; for (my $i =0; $i <=$#{$s->{-i}}; $i++) { if (ref($s->{-i}->[$i]) eq 'HASH') { use locale; my $h =$s->{-i}->[$i]; $s->{-i}->[$i] =[ map {[$_, $h->$_] } sort { $s->{-asc} ? lc($h->{$a}) cmp lc($h->{$b}) : lc($h->{$b}) cmp lc($h->{$a}) } keys %$h ]; $s->{-rl} =1 if !defined($s->{-rl}); } if (ref($s->{-i}->[$i]) eq 'ARRAY') { $s->{-d}->[$i] =[]; @{$s->{-d}->[$i]} =ref($s->{-i}->[$i]->[0]) ? @{$s->{-i}->[$i]->[0]} : $s->{-i}->[$i]->[0]; $s->{-j}->[$i] =0; } elsif ($s->{-i}->[$i]) { if (!$s->{'NAME'}) { eval{$s->{'NAME'}=$s->{-i}->[$i]->{'NAME'} if ref($s->{-i}->[$i]->{'NAME'})}; if (ref($s->{'NAME'})) {eval{ @{$s->{-rec}}[@{$s->{NAME}}] =(); @{$s->{-rfr}} =map {\($s->{-rec}->{$_})} @{$s->{NAME}}; }} } $s->{-d}->[$i] =$s->{-i}->[$i]->fetch(@_[1..$#_]); } else { $s->{-d}->[$i] =undef; } } } my $m =undef; for (my $i =0; $i <=$#{$s->{-i}}; $i++) { if (!defined($s->{-d}->[$i])) { next } elsif (!defined($m)) { $m =$i; next; } my ($vm, $vc) =($s->{-d}->[$m], $s->{-d}->[$i]); my ($ce, $cc) =(1, 0); my $j =$s->{-rl} ? $#{$vc} : 0; {use locale; while(1) { $ce =0 if $ce && ( !defined($vm->[$j]) && !defined($vc->[$j]) ? undef : !defined($vm->[$j]) || !defined($vc->[$j]) ? 1 : ($vm->[$j] ne $vc->[$j])); $cc =1 if !$cc && ($s->{-asc} ? ( !defined($vc->[$j]) && !defined($vm->[$j]) ? undef : !defined($vc->[$j]) ? 1 : !defined($vm->[$j]) ? undef : ($vc->[$j] =~/^\d+$/) && ($vm->[$j] =~/^\d+$/) ? $vc->[$j] < $vm->[$j] : $s->{-lc} ? lc($vc->[$j]) lt lc($vm->[$j]) : $vc->[$j] lt $vm->[$j]) : ( !defined($vc->[$j]) && !defined($vm->[$j]) ? undef : !defined($vc->[$j]) ? undef : !defined($vm->[$j]) ? 1 : ($vc->[$j] =~/^\d+$/) && ($vm->[$j] =~/^\d+$/) ? $vc->[$j] > $vm->[$j] : $s->{-lc} ? lc($vc->[$j]) gt lc($vm->[$j]) : $vc->[$j] gt $vm->[$j]) ); last if $cc; if ($s->{-rl}) { $j--; last if $j <0 } else { $j++; last if $j >$#{$vc} } }} # print '[', join(';' , map {$_ ? join(',',@$_) : 'u'} @{$s->{-d}}), ']', # $ce || 'ne', $cc ||'nc',"\n"; if ($cc) { $m =$i } elsif ($ce && $s->{-all}) { } elsif ($ce) { if (ref($s->{-i}->[$i]) ne 'ARRAY') { $s->{-d}->[$i] =$s->{-i}->[$i]->fetch(@_[1..$#_]) } elsif (++$s->{-j}->[$i] >$#{$s->{-i}->[$i]}) { $s->{-d}->[$i] =undef; $s->{-j}->[$i] =$#{$s->{-i}->[$i]} +1; } elsif (ref($s->{-i}->[$i]->[$s->{-j}->[$i]])) { @{$s->{-d}->[$i]} =@{$s->{-i}->[$i]->[$s->{-j}->[$i]]} } else { $s->{-d}->[$i]->[0] =$s->{-i}->[$i]->[$s->{-j}->[$i]] } } } if (!defined($m)) { return($s->{-rfr} =undef) } else { @{$s->{-rfr}} =@{$s->{-d}->[$m]}; # $s->{-rfr}->[0] =$m .' ' .$s->{-rfr}->[0]; # @{$s->{-rec}}[@{$s->{'NAME'}}] =@{$s->{-d}->[$m]} # if $s->{'NAME'}; my $i =$m; if (ref($s->{-i}->[$i]) ne 'ARRAY') { $s->{-d}->[$i] =$s->{-i}->[$i]->fetch(@_[1..$#_]) } elsif (++$s->{-j}->[$i] >$#{$s->{-i}->[$i]}) { $s->{-d}->[$i] =undef; $s->{-j}->[$i] =$#{$s->{-i}->[$i]} +1; } elsif (ref($s->{-i}->[$i]->[$s->{-j}->[$i]])) { @{$s->{-d}->[$i]} =@{$s->{-i}->[$i]->[$s->{-j}->[$i]]} } else { $s->{-d}->[$i]->[0] =$s->{-i}->[$i]->[$s->{-j}->[$i]] } return($s->{-rfr}) } } sub fetchrow_arrayref { $_[0]->fetch(@_[1..$#_]) } sub fetchrow_hashref { $_[0]->fetch(@_[1..$#_]) && $_[0]->{-rec} } sub finish { my $s=$_[0]; return($s) if !$s->{-i}; foreach my $e (@{$s->{-i}}) { eval{$e->finish()} if $e && (ref($e) !~/^(?:ARRAY|HASH)$/) } $s } sub close { $_[0]->finish(); $_[0]->{-i} =undef; $_[0] } sub DESTROY { eval{$_[0]->close()} }