From 8b72e98b0459a3a35fd604adf415088440e5db2e Mon Sep 17 00:00:00 2001 From: Kilian Saffran Date: Sun, 5 May 2019 19:08:30 +0200 Subject: [PATCH] website update --- .DS_Store | Bin 6148 -> 0 bytes apps/api/lib/pgsql.pm | 8 +- apps/api/prefs.cgi | 2 +- apps/api/sqlite.cgi | 2 +- apps/index.cgi | 2 +- apps/js/apps.js | 2 +- apps/lib/CGI.pm | 3870 + apps/lib/CGI/Carp.pm | 318 + apps/lib/CGI/Cookie.pm | 244 + apps/lib/CGI/File/Temp.pm | 45 + apps/lib/CGI/Util.pm | 321 + apps/lib/DBD/DBM.pm | 625 + apps/lib/DBD/ExampleP.pm | 436 + apps/lib/DBD/File.pm | 968 + apps/lib/DBD/Gofer.pm | 814 + apps/lib/DBD/Gofer/Policy/Base.pm | 88 + apps/lib/DBD/Gofer/Policy/classic.pm | 53 + apps/lib/DBD/Gofer/Policy/pedantic.pm | 23 + apps/lib/DBD/Gofer/Policy/rush.pm | 63 + apps/lib/DBD/Gofer/Transport/Base.pm | 294 + apps/lib/DBD/Gofer/Transport/corostream.pm | 29 + apps/lib/DBD/Gofer/Transport/null.pm | 65 + apps/lib/DBD/Gofer/Transport/pipeone.pm | 212 + apps/lib/DBD/Gofer/Transport/stream.pm | 216 + apps/lib/DBD/NullP.pm | 207 + {lib => apps/lib}/DBD/PgPP.pm | 273 +- apps/lib/DBD/SQLite.pm | 1004 + {lib => apps/lib}/DBD/SQLite/Constants.pm | 422 +- {lib => apps/lib}/DBD/SQLite/GetInfo.pm | 1 + apps/lib/DBD/SQLite/VirtualTable.pm | 227 + .../DBD/SQLite/VirtualTable/FileContent.pm | 97 +- .../lib}/DBD/SQLite/VirtualTable/PerlData.pm | 214 +- apps/lib/DBD/Sponge.pm | 220 + apps/lib/DBD/mysql.pm | 890 + apps/lib/DBD/mysql/GetInfo.pm | 310 + apps/lib/DBI.pm | 2019 + apps/lib/DBI/Const/GetInfo/ANSI.pm | 198 + apps/lib/DBI/Const/GetInfo/ODBC.pm | 1323 + apps/lib/DBI/Const/GetInfoType.pm | 36 + apps/lib/DBI/DBD/SqlEngine.pm | 1668 + apps/lib/DBI/Gofer/Execute.pm | 714 + apps/lib/DBI/Gofer/Request.pm | 182 + apps/lib/DBI/Gofer/Response.pm | 200 + apps/lib/DBI/Gofer/Serializer/Base.pm | 45 + apps/lib/DBI/Gofer/Serializer/DataDumper.pm | 37 + apps/lib/DBI/Gofer/Serializer/Storable.pm | 39 + apps/lib/DBI/Gofer/Transport/Base.pm | 152 + apps/lib/DBI/PurePerl.pm | 1112 + apps/lib/DBI/SQL/Nano.pm | 812 + apps/lib/DBI/Util/_accessor.pm | 66 + {lib => apps/lib}/Digest/SHA/PurePerl.pm | 559 +- apps/lib/Fh.pm | 11 + apps/lib/HTML/Entities.pm | 353 + apps/lib/HTML/Parser.pm | 128 + apps/lib/JSON/PP.pm | 1746 + apps/lib/JSON/PP/Boolean.pm | 21 + apps/lib/Template.pm | 230 + {lib => apps/lib}/Template/Base.pm | 132 +- {lib => apps/lib}/Template/Config.pm | 124 +- {lib => apps/lib}/Template/Constants.pm | 99 +- {lib => apps/lib}/Template/Context.pm | 583 +- {lib => apps/lib}/Template/Directive.pm | 44 +- {lib => apps/lib}/Template/Document.pm | 198 +- {lib => apps/lib}/Template/Exception.pm | 80 +- {lib => apps/lib}/Template/Filters.pm | 165 +- {lib => apps/lib}/Template/Grammar.pm | 39 +- {lib => apps/lib}/Template/Iterator.pm | 231 +- .../lib}/Template/Namespace/Constants.pm | 71 +- {lib => apps/lib}/Template/Parser.pm | 204 +- apps/lib/Template/Plugin.pm | 162 + {lib => apps/lib}/Template/Plugin/Assert.pm | 51 +- apps/lib/Template/Plugin/CGI.pm | 67 + {lib => apps/lib}/Template/Plugin/DBI.pm | 469 +- apps/lib/Template/Plugin/Datafile.pm | 96 + {lib => apps/lib}/Template/Plugin/Date.pm | 146 +- apps/lib/Template/Plugin/Directory.pm | 168 + {lib => apps/lib}/Template/Plugin/Dumper.pm | 74 +- apps/lib/Template/Plugin/File.pm | 149 + apps/lib/Template/Plugin/Filter.pm | 130 + {lib => apps/lib}/Template/Plugin/Format.pm | 36 +- apps/lib/Template/Plugin/HTML.pm | 143 + apps/lib/Template/Plugin/Image.pm | 216 + {lib => apps/lib}/Template/Plugin/Iterator.pm | 39 +- {lib => apps/lib}/Template/Plugin/Math.pm | 156 +- {lib => apps/lib}/Template/Plugin/Pod.pm | 37 +- .../lib}/Template/Plugin/Procedural.pm | 50 +- {lib => apps/lib}/Template/Plugin/Scalar.pm | 41 +- apps/lib/Template/Plugin/String.pm | 395 + {lib => apps/lib}/Template/Plugin/Table.pm | 208 +- apps/lib/Template/Plugin/URL.pm | 97 + apps/lib/Template/Plugin/View.pm | 57 + apps/lib/Template/Plugin/Wrap.pm | 59 + {lib => apps/lib}/Template/Plugins.pm | 165 +- {lib => apps/lib}/Template/Provider.pm | 317 +- apps/lib/Template/Service.pm | 296 + {lib => apps/lib}/Template/Stash.pm | 205 +- {lib => apps/lib}/Template/Stash/Context.pm | 93 +- apps/lib/Template/Stash/XS.pm | 59 + {lib => apps/lib}/Template/Test.pm | 304 +- apps/lib/Template/Toolkit.pm | 34 + {lib => apps/lib}/Template/VMethods.pm | 31 +- {lib => apps/lib}/Template/View.pm | 272 +- {lib => apps/lib}/URI/Encode.pm | 166 +- apps/lib/auto/DBD/SQLite/SQLite.so | Bin 0 -> 5905272 bytes apps/lib/auto/DBD/mysql/mysql.so | Bin 0 -> 120936 bytes apps/lib/auto/DBI/DBI.so | Bin 0 -> 133048 bytes apps/lib/auto/DBI/DBIXS.h | 573 + apps/lib/auto/DBI/Driver.xst | 803 + apps/lib/auto/DBI/Driver_xst.h | 122 + apps/lib/auto/DBI/dbd_xsh.h | 61 + apps/lib/auto/DBI/dbi_sql.h | 96 + apps/lib/auto/DBI/dbipport.h | 7748 + apps/lib/auto/DBI/dbivport.h | 52 + apps/lib/auto/DBI/dbixs_rev.h | 3 + apps/lib/auto/HTML/Parser/Parser.so | Bin 0 -> 51112 bytes apps/lib/auto/Template/Stash/XS/XS.so | Bin 0 -> 138880 bytes apps/lib/auto/share/dist/DBD-SQLite/sqlite3.c | 220533 +++++++++++++++ apps/lib/auto/share/dist/DBD-SQLite/sqlite3.h | 11691 + .../auto/share/dist/DBD-SQLite/sqlite3ext.h | 628 + apps/sql.log | 198 - css/site.css | 15 +- index.cgi | 4 +- lib/Convert/BinHex.pm | 1711 - lib/DBD/SQLite.pm | 2765 - lib/DBD/SQLite/Cookbook.pod | 172 - lib/DBD/SQLite/Fulltext_search.pod | 514 - lib/DBD/SQLite/VirtualTable.pm | 824 - lib/Email/Send.pm | 383 - lib/Email/Send/NNTP.pm | 80 - lib/Email/Send/Qmail.pm | 100 - lib/Email/Send/SMTP.pm | 207 - lib/Email/Send/Sendmail.pm | 111 - lib/Email/Send/Test.pm | 191 - lib/JSON/PP.pm | 2853 - lib/JSON/PP/Boolean.pm | 35 - lib/MIME/Body.pm | 672 - lib/MIME/Decoder.pm | 661 - lib/MIME/Decoder/Base64.pm | 137 - lib/MIME/Decoder/BinHex.pm | 183 - lib/MIME/Decoder/Binary.pm | 86 - lib/MIME/Decoder/Gzip64.pm | 111 - lib/MIME/Decoder/NBit.pm | 160 - lib/MIME/Decoder/QuotedPrint.pm | 159 - lib/MIME/Decoder/UU.pm | 151 - lib/MIME/Entity.pm | 2272 - lib/MIME/Field/ConTraEnc.pm | 63 - lib/MIME/Field/ContDisp.pm | 68 - lib/MIME/Field/ContType.pm | 196 - lib/MIME/Field/ParamVal.pm | 416 - lib/MIME/Head.pm | 930 - lib/MIME/Lite.pm | 3709 - lib/MIME/Lite/HTML.pm | 1242 - lib/MIME/Parser.pm | 2009 - lib/MIME/Parser/Filer.pm | 940 - lib/MIME/Parser/Reader.pm | 328 - lib/MIME/Parser/Results.pm | 186 - lib/MIME/Tools.pm | 1046 - lib/MIME/WordDecoder.pm | 682 - lib/MIME/Words.pm | 353 - lib/MIME/changes.pod | 508 - lib/Net/CIDR.pm | 1321 - lib/Net/EmptyPort.pm | 336 - lib/Net/Ping.pm | 2579 - lib/Net/SMTP/TLS.pm | 401 - lib/PDF/API2.pm | 2412 - lib/PDF/API2/Annotation.pm | 395 - lib/PDF/API2/Basic/PDF/Array.pm | 141 - lib/PDF/API2/Basic/PDF/Bool.pm | 48 - lib/PDF/API2/Basic/PDF/Dict.pm | 329 - lib/PDF/API2/Basic/PDF/File.pm | 1380 - lib/PDF/API2/Basic/PDF/Filter.pm | 114 - .../API2/Basic/PDF/Filter/ASCII85Decode.pm | 88 - .../API2/Basic/PDF/Filter/ASCIIHexDecode.pm | 58 - lib/PDF/API2/Basic/PDF/Filter/FlateDecode.pm | 150 - lib/PDF/API2/Basic/PDF/Filter/LZWDecode.pm | 97 - .../API2/Basic/PDF/Filter/RunLengthDecode.pm | 109 - lib/PDF/API2/Basic/PDF/Literal.pm | 87 - lib/PDF/API2/Basic/PDF/Name.pm | 116 - lib/PDF/API2/Basic/PDF/Null.pm | 94 - lib/PDF/API2/Basic/PDF/Number.pm | 47 - lib/PDF/API2/Basic/PDF/Objind.pm | 303 - lib/PDF/API2/Basic/PDF/Page.pm | 130 - lib/PDF/API2/Basic/PDF/Pages.pm | 435 - lib/PDF/API2/Basic/PDF/String.pm | 221 - lib/PDF/API2/Basic/PDF/Utils.pm | 140 - lib/PDF/API2/Content.pm | 2239 - lib/PDF/API2/Content/Text.pm | 17 - lib/PDF/API2/Lite.pm | 642 - lib/PDF/API2/Matrix.pm | 72 - lib/PDF/API2/NamedDestination.pm | 264 - lib/PDF/API2/Outline.pm | 348 - lib/PDF/API2/Outlines.pm | 20 - lib/PDF/API2/Page.pm | 418 - lib/PDF/API2/Resource.pm | 82 - lib/PDF/API2/Resource/BaseFont.pm | 784 - lib/PDF/API2/Resource/CIDFont.pm | 348 - lib/PDF/API2/Resource/CIDFont/CJKFont.pm | 326 - .../CJKFont/adobemingstdlightacro.data | 17634 -- .../CJKFont/adobemyungjostdmediumacro.data | 8219 - .../CJKFont/adobesongstdlightacro.data | 22385 -- .../CIDFont/CJKFont/kozgopromediumacro.data | 659 - .../CIDFont/CJKFont/kozminproregularacro.data | 660 - .../API2/Resource/CIDFont/CMap/japanese.cmap | 55931 ---- .../API2/Resource/CIDFont/CMap/korean.cmap | 35662 --- .../Resource/CIDFont/CMap/simplified.cmap | 58164 ---- .../Resource/CIDFont/CMap/traditional.cmap | 42828 --- lib/PDF/API2/Resource/CIDFont/TrueType.pm | 184 - .../Resource/CIDFont/TrueType/FontFile.pm | 680 - lib/PDF/API2/Resource/ColorSpace.pm | 86 - lib/PDF/API2/Resource/ColorSpace/DeviceN.pm | 86 - lib/PDF/API2/Resource/ColorSpace/Indexed.pm | 114 - .../Resource/ColorSpace/Indexed/ACTFile.pm | 68 - .../API2/Resource/ColorSpace/Indexed/Hue.pm | 51 - .../Resource/ColorSpace/Indexed/WebColor.pm | 59 - .../API2/Resource/ColorSpace/Separation.pm | 149 - lib/PDF/API2/Resource/Colors.pm | 695 - lib/PDF/API2/Resource/ExtGState.pm | 364 - lib/PDF/API2/Resource/Font.pm | 211 - lib/PDF/API2/Resource/Font/BdFont.pm | 242 - lib/PDF/API2/Resource/Font/CoreFont.pm | 374 - .../API2/Resource/Font/CoreFont/bankgothic.pm | 515 - .../API2/Resource/Font/CoreFont/courier.pm | 788 - .../Resource/Font/CoreFont/courierbold.pm | 518 - .../Font/CoreFont/courierboldoblique.pm | 518 - .../Resource/Font/CoreFont/courieroblique.pm | 518 - .../API2/Resource/Font/CoreFont/georgia.pm | 861 - .../Resource/Font/CoreFont/georgiabold.pm | 861 - .../Font/CoreFont/georgiabolditalic.pm | 861 - .../Resource/Font/CoreFont/georgiaitalic.pm | 861 - .../API2/Resource/Font/CoreFont/helvetica.pm | 518 - .../Resource/Font/CoreFont/helveticabold.pm | 518 - .../Font/CoreFont/helveticaboldoblique.pm | 517 - .../Font/CoreFont/helveticaoblique.pm | 517 - lib/PDF/API2/Resource/Font/CoreFont/symbol.pm | 479 - .../API2/Resource/Font/CoreFont/timesbold.pm | 518 - .../Resource/Font/CoreFont/timesbolditalic.pm | 517 - .../Resource/Font/CoreFont/timesitalic.pm | 519 - .../API2/Resource/Font/CoreFont/timesroman.pm | 604 - .../API2/Resource/Font/CoreFont/trebuchet.pm | 575 - .../Resource/Font/CoreFont/trebuchetbold.pm | 575 - .../Font/CoreFont/trebuchetbolditalic.pm | 633 - .../Resource/Font/CoreFont/trebuchetitalic.pm | 633 - .../API2/Resource/Font/CoreFont/verdana.pm | 842 - .../Resource/Font/CoreFont/verdanabold.pm | 846 - .../Font/CoreFont/verdanabolditalic.pm | 846 - .../Resource/Font/CoreFont/verdanaitalic.pm | 845 - .../API2/Resource/Font/CoreFont/webdings.pm | 768 - .../API2/Resource/Font/CoreFont/wingdings.pm | 510 - .../Resource/Font/CoreFont/zapfdingbats.pm | 492 - lib/PDF/API2/Resource/Font/Postscript.pm | 497 - lib/PDF/API2/Resource/Font/SynFont.pm | 246 - lib/PDF/API2/Resource/Glyphs.pm | 9780 - lib/PDF/API2/Resource/PaperSizes.pm | 47 - lib/PDF/API2/Resource/Pattern.pm | 19 - lib/PDF/API2/Resource/Shading.pm | 10 - lib/PDF/API2/Resource/UniFont.pm | 273 - lib/PDF/API2/Resource/XObject.pm | 53 - lib/PDF/API2/Resource/XObject/Form.pm | 92 - lib/PDF/API2/Resource/XObject/Form/BarCode.pm | 190 - .../Resource/XObject/Form/BarCode/codabar.pm | 36 - .../Resource/XObject/Form/BarCode/code128.pm | 239 - .../Resource/XObject/Form/BarCode/code3of9.pm | 113 - .../Resource/XObject/Form/BarCode/ean13.pm | 78 - .../Resource/XObject/Form/BarCode/int2of5.pm | 62 - lib/PDF/API2/Resource/XObject/Form/Hybrid.pm | 58 - lib/PDF/API2/Resource/XObject/Image.pm | 145 - lib/PDF/API2/Resource/XObject/Image/GD.pm | 72 - lib/PDF/API2/Resource/XObject/Image/GIF.pm | 227 - lib/PDF/API2/Resource/XObject/Image/JPEG.pm | 97 - lib/PDF/API2/Resource/XObject/Image/PNG.pm | 692 - lib/PDF/API2/Resource/XObject/Image/PNM.pm | 185 - lib/PDF/API2/Resource/XObject/Image/TIFF.pm | 317 - .../API2/Resource/XObject/Image/TIFF/File.pm | 281 - lib/PDF/API2/Resource/uniglyph.txt | 5509 - lib/PDF/API2/Simple.pm | 1311 - lib/PDF/API2/UniWrap.pm | 309 - lib/PDF/API2/Util.pm | 712 - lib/PDF/API2/Win32.pm | 85 - lib/Return/Value.pm | 619 - lib/Template.pm | 935 - lib/Template/DBI.pod | 52 - lib/Template/FAQ.pod | 329 - lib/Template/Manual.pod | 91 - lib/Template/Manual/Config.pod | 1918 - lib/Template/Manual/Credits.pod | 107 - lib/Template/Manual/Directives.pod | 1970 - lib/Template/Manual/Filters.pod | 504 - lib/Template/Manual/Internals.pod | 452 - lib/Template/Manual/Intro.pod | 242 - lib/Template/Manual/Plugins.pod | 313 - lib/Template/Manual/Syntax.pod | 327 - lib/Template/Manual/VMethods.pod | 721 - lib/Template/Manual/Variables.pod | 838 - lib/Template/Manual/Views.pod | 586 - lib/Template/Modules.pod | 176 - lib/Template/Plugin.pm | 369 - lib/Template/Plugin/CGI.pm | 135 - lib/Template/Plugin/Datafile.pm | 166 - lib/Template/Plugin/Directory.pm | 386 - lib/Template/Plugin/File.pm | 391 - lib/Template/Plugin/Filter.pm | 411 - lib/Template/Plugin/HTML.pm | 251 - lib/Template/Plugin/Image.pm | 436 - lib/Template/Plugin/String.pm | 761 - lib/Template/Plugin/URL.pm | 204 - lib/Template/Plugin/View.pm | 97 - lib/Template/Plugin/Wrap.pm | 142 - lib/Template/Service.pm | 573 - lib/Template/Stash/XS.pm | 137 - lib/Template/Tiny.pm | 346 - lib/Template/Toolkit.pm | 146 - lib/Template/Tools.pod | 65 - lib/Template/Tools/tpage.pod | 64 - lib/Template/Tools/ttree.pod | 314 - lib/Template/Tutorial.pod | 43 - lib/Template/Tutorial/Datafile.pod | 437 - lib/Template/Tutorial/Web.pod | 749 - lib/sendEmail | 2235 - tmpl/menu/topmenu.tt | 8 +- tmpl/page/hosting.tt | 76 +- tmpl/page/index.tt | 202 +- tmpl/page/product/cashbox.tt | 5 +- tmpl/page/product/coloradio.tt | 7 +- tmpl/page/product/creorga.tt | 94 +- tmpl/page/product/hourtrax.tt | 60 + tmpl/page/product/websites.tt | 0 tmpl/page/service.tt | 8 +- 327 files changed, 267486 insertions(+), 355831 deletions(-) delete mode 100644 .DS_Store create mode 100644 apps/lib/CGI.pm create mode 100644 apps/lib/CGI/Carp.pm create mode 100644 apps/lib/CGI/Cookie.pm create mode 100644 apps/lib/CGI/File/Temp.pm create mode 100644 apps/lib/CGI/Util.pm create mode 100644 apps/lib/DBD/DBM.pm create mode 100644 apps/lib/DBD/ExampleP.pm create mode 100644 apps/lib/DBD/File.pm create mode 100644 apps/lib/DBD/Gofer.pm create mode 100644 apps/lib/DBD/Gofer/Policy/Base.pm create mode 100644 apps/lib/DBD/Gofer/Policy/classic.pm create mode 100644 apps/lib/DBD/Gofer/Policy/pedantic.pm create mode 100644 apps/lib/DBD/Gofer/Policy/rush.pm create mode 100644 apps/lib/DBD/Gofer/Transport/Base.pm create mode 100644 apps/lib/DBD/Gofer/Transport/corostream.pm create mode 100644 apps/lib/DBD/Gofer/Transport/null.pm create mode 100644 apps/lib/DBD/Gofer/Transport/pipeone.pm create mode 100644 apps/lib/DBD/Gofer/Transport/stream.pm create mode 100644 apps/lib/DBD/NullP.pm rename {lib => apps/lib}/DBD/PgPP.pm (81%) create mode 100644 apps/lib/DBD/SQLite.pm rename {lib => apps/lib}/DBD/SQLite/Constants.pm (71%) rename {lib => apps/lib}/DBD/SQLite/GetInfo.pm (99%) create mode 100644 apps/lib/DBD/SQLite/VirtualTable.pm rename {lib => apps/lib}/DBD/SQLite/VirtualTable/FileContent.pm (71%) rename {lib => apps/lib}/DBD/SQLite/VirtualTable/PerlData.pm (54%) create mode 100644 apps/lib/DBD/Sponge.pm create mode 100644 apps/lib/DBD/mysql.pm create mode 100644 apps/lib/DBD/mysql/GetInfo.pm create mode 100644 apps/lib/DBI.pm create mode 100644 apps/lib/DBI/Const/GetInfo/ANSI.pm create mode 100644 apps/lib/DBI/Const/GetInfo/ODBC.pm create mode 100644 apps/lib/DBI/Const/GetInfoType.pm create mode 100644 apps/lib/DBI/DBD/SqlEngine.pm create mode 100644 apps/lib/DBI/Gofer/Execute.pm create mode 100644 apps/lib/DBI/Gofer/Request.pm create mode 100644 apps/lib/DBI/Gofer/Response.pm create mode 100644 apps/lib/DBI/Gofer/Serializer/Base.pm create mode 100644 apps/lib/DBI/Gofer/Serializer/DataDumper.pm create mode 100644 apps/lib/DBI/Gofer/Serializer/Storable.pm create mode 100644 apps/lib/DBI/Gofer/Transport/Base.pm create mode 100644 apps/lib/DBI/PurePerl.pm create mode 100644 apps/lib/DBI/SQL/Nano.pm create mode 100644 apps/lib/DBI/Util/_accessor.pm rename {lib => apps/lib}/Digest/SHA/PurePerl.pm (64%) create mode 100644 apps/lib/Fh.pm create mode 100644 apps/lib/HTML/Entities.pm create mode 100644 apps/lib/HTML/Parser.pm create mode 100644 apps/lib/JSON/PP.pm create mode 100644 apps/lib/JSON/PP/Boolean.pm create mode 100644 apps/lib/Template.pm rename {lib => apps/lib}/Template/Base.pm (54%) rename {lib => apps/lib}/Template/Config.pm (70%) rename {lib => apps/lib}/Template/Constants.pm (65%) rename {lib => apps/lib}/Template/Context.pm (63%) rename {lib => apps/lib}/Template/Directive.pm (97%) rename {lib => apps/lib}/Template/Document.pm (59%) rename {lib => apps/lib}/Template/Exception.pm (64%) rename {lib => apps/lib}/Template/Filters.pm (80%) rename {lib => apps/lib}/Template/Grammar.pm (99%) rename {lib => apps/lib}/Template/Iterator.pm (57%) rename {lib => apps/lib}/Template/Namespace/Constants.pm (62%) rename {lib => apps/lib}/Template/Parser.pm (86%) create mode 100644 apps/lib/Template/Plugin.pm rename {lib => apps/lib}/Template/Plugin/Assert.pm (67%) create mode 100644 apps/lib/Template/Plugin/CGI.pm rename {lib => apps/lib}/Template/Plugin/DBI.pm (56%) create mode 100644 apps/lib/Template/Plugin/Datafile.pm rename {lib => apps/lib}/Template/Plugin/Date.pm (58%) create mode 100644 apps/lib/Template/Plugin/Directory.pm rename {lib => apps/lib}/Template/Plugin/Dumper.pm (53%) create mode 100644 apps/lib/Template/Plugin/File.pm create mode 100644 apps/lib/Template/Plugin/Filter.pm rename {lib => apps/lib}/Template/Plugin/Format.pm (61%) create mode 100644 apps/lib/Template/Plugin/HTML.pm create mode 100644 apps/lib/Template/Plugin/Image.pm rename {lib => apps/lib}/Template/Plugin/Iterator.pm (55%) rename {lib => apps/lib}/Template/Plugin/Math.pm (58%) rename {lib => apps/lib}/Template/Plugin/Pod.pm (60%) rename {lib => apps/lib}/Template/Plugin/Procedural.pm (60%) rename {lib => apps/lib}/Template/Plugin/Scalar.pm (76%) create mode 100644 apps/lib/Template/Plugin/String.pm rename {lib => apps/lib}/Template/Plugin/Table.pm (51%) create mode 100644 apps/lib/Template/Plugin/URL.pm create mode 100644 apps/lib/Template/Plugin/View.pm create mode 100644 apps/lib/Template/Plugin/Wrap.pm rename {lib => apps/lib}/Template/Plugins.pm (65%) rename {lib => apps/lib}/Template/Provider.pm (79%) create mode 100644 apps/lib/Template/Service.pm rename {lib => apps/lib}/Template/Stash.pm (78%) rename {lib => apps/lib}/Template/Stash/Context.pm (89%) create mode 100644 apps/lib/Template/Stash/XS.pm rename {lib => apps/lib}/Template/Test.pm (57%) create mode 100644 apps/lib/Template/Toolkit.pm rename {lib => apps/lib}/Template/VMethods.pm (96%) rename {lib => apps/lib}/Template/View.pm (70%) rename {lib => apps/lib}/URI/Encode.pm (52%) create mode 100644 apps/lib/auto/DBD/SQLite/SQLite.so create mode 100644 apps/lib/auto/DBD/mysql/mysql.so create mode 100644 apps/lib/auto/DBI/DBI.so create mode 100644 apps/lib/auto/DBI/DBIXS.h create mode 100644 apps/lib/auto/DBI/Driver.xst create mode 100644 apps/lib/auto/DBI/Driver_xst.h create mode 100644 apps/lib/auto/DBI/dbd_xsh.h create mode 100644 apps/lib/auto/DBI/dbi_sql.h create mode 100644 apps/lib/auto/DBI/dbipport.h create mode 100644 apps/lib/auto/DBI/dbivport.h create mode 100644 apps/lib/auto/DBI/dbixs_rev.h create mode 100644 apps/lib/auto/HTML/Parser/Parser.so create mode 100644 apps/lib/auto/Template/Stash/XS/XS.so create mode 100644 apps/lib/auto/share/dist/DBD-SQLite/sqlite3.c create mode 100644 apps/lib/auto/share/dist/DBD-SQLite/sqlite3.h create mode 100644 apps/lib/auto/share/dist/DBD-SQLite/sqlite3ext.h delete mode 100644 apps/sql.log delete mode 100644 lib/Convert/BinHex.pm delete mode 100644 lib/DBD/SQLite.pm delete mode 100644 lib/DBD/SQLite/Cookbook.pod delete mode 100644 lib/DBD/SQLite/Fulltext_search.pod delete mode 100644 lib/DBD/SQLite/VirtualTable.pm delete mode 100644 lib/Email/Send.pm delete mode 100644 lib/Email/Send/NNTP.pm delete mode 100644 lib/Email/Send/Qmail.pm delete mode 100644 lib/Email/Send/SMTP.pm delete mode 100644 lib/Email/Send/Sendmail.pm delete mode 100644 lib/Email/Send/Test.pm delete mode 100644 lib/JSON/PP.pm delete mode 100644 lib/JSON/PP/Boolean.pm delete mode 100644 lib/MIME/Body.pm delete mode 100644 lib/MIME/Decoder.pm delete mode 100644 lib/MIME/Decoder/Base64.pm delete mode 100644 lib/MIME/Decoder/BinHex.pm delete mode 100644 lib/MIME/Decoder/Binary.pm delete mode 100644 lib/MIME/Decoder/Gzip64.pm delete mode 100644 lib/MIME/Decoder/NBit.pm delete mode 100644 lib/MIME/Decoder/QuotedPrint.pm delete mode 100644 lib/MIME/Decoder/UU.pm delete mode 100644 lib/MIME/Entity.pm delete mode 100644 lib/MIME/Field/ConTraEnc.pm delete mode 100644 lib/MIME/Field/ContDisp.pm delete mode 100644 lib/MIME/Field/ContType.pm delete mode 100644 lib/MIME/Field/ParamVal.pm delete mode 100644 lib/MIME/Head.pm delete mode 100644 lib/MIME/Lite.pm delete mode 100644 lib/MIME/Lite/HTML.pm delete mode 100644 lib/MIME/Parser.pm delete mode 100644 lib/MIME/Parser/Filer.pm delete mode 100644 lib/MIME/Parser/Reader.pm delete mode 100644 lib/MIME/Parser/Results.pm delete mode 100644 lib/MIME/Tools.pm delete mode 100644 lib/MIME/WordDecoder.pm delete mode 100644 lib/MIME/Words.pm delete mode 100644 lib/MIME/changes.pod delete mode 100644 lib/Net/CIDR.pm delete mode 100644 lib/Net/EmptyPort.pm delete mode 100644 lib/Net/Ping.pm delete mode 100644 lib/Net/SMTP/TLS.pm delete mode 100644 lib/PDF/API2.pm delete mode 100644 lib/PDF/API2/Annotation.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Array.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Bool.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Dict.pm delete mode 100644 lib/PDF/API2/Basic/PDF/File.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Filter.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Filter/ASCII85Decode.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Filter/ASCIIHexDecode.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Filter/FlateDecode.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Filter/LZWDecode.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Filter/RunLengthDecode.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Literal.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Name.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Null.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Number.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Objind.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Page.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Pages.pm delete mode 100644 lib/PDF/API2/Basic/PDF/String.pm delete mode 100644 lib/PDF/API2/Basic/PDF/Utils.pm delete mode 100644 lib/PDF/API2/Content.pm delete mode 100644 lib/PDF/API2/Content/Text.pm delete mode 100644 lib/PDF/API2/Lite.pm delete mode 100644 lib/PDF/API2/Matrix.pm delete mode 100644 lib/PDF/API2/NamedDestination.pm delete mode 100644 lib/PDF/API2/Outline.pm delete mode 100644 lib/PDF/API2/Outlines.pm delete mode 100644 lib/PDF/API2/Page.pm delete mode 100644 lib/PDF/API2/Resource.pm delete mode 100644 lib/PDF/API2/Resource/BaseFont.pm delete mode 100644 lib/PDF/API2/Resource/CIDFont.pm delete mode 100644 lib/PDF/API2/Resource/CIDFont/CJKFont.pm delete mode 100644 lib/PDF/API2/Resource/CIDFont/CJKFont/adobemingstdlightacro.data delete mode 100644 lib/PDF/API2/Resource/CIDFont/CJKFont/adobemyungjostdmediumacro.data delete mode 100644 lib/PDF/API2/Resource/CIDFont/CJKFont/adobesongstdlightacro.data delete mode 100644 lib/PDF/API2/Resource/CIDFont/CJKFont/kozgopromediumacro.data delete mode 100644 lib/PDF/API2/Resource/CIDFont/CJKFont/kozminproregularacro.data delete mode 100644 lib/PDF/API2/Resource/CIDFont/CMap/japanese.cmap delete mode 100644 lib/PDF/API2/Resource/CIDFont/CMap/korean.cmap delete mode 100644 lib/PDF/API2/Resource/CIDFont/CMap/simplified.cmap delete mode 100644 lib/PDF/API2/Resource/CIDFont/CMap/traditional.cmap delete mode 100644 lib/PDF/API2/Resource/CIDFont/TrueType.pm delete mode 100644 lib/PDF/API2/Resource/CIDFont/TrueType/FontFile.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace/DeviceN.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace/Indexed.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace/Indexed/ACTFile.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace/Indexed/Hue.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace/Indexed/WebColor.pm delete mode 100644 lib/PDF/API2/Resource/ColorSpace/Separation.pm delete mode 100644 lib/PDF/API2/Resource/Colors.pm delete mode 100644 lib/PDF/API2/Resource/ExtGState.pm delete mode 100644 lib/PDF/API2/Resource/Font.pm delete mode 100644 lib/PDF/API2/Resource/Font/BdFont.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/bankgothic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/courier.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/courierbold.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/courierboldoblique.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/courieroblique.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/georgia.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/georgiabold.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/georgiabolditalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/georgiaitalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/helvetica.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/helveticabold.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/helveticaboldoblique.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/helveticaoblique.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/symbol.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/timesbold.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/timesbolditalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/timesitalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/timesroman.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/trebuchet.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/trebuchetbold.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/trebuchetbolditalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/trebuchetitalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/verdana.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/verdanabold.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/verdanabolditalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/verdanaitalic.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/webdings.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/wingdings.pm delete mode 100644 lib/PDF/API2/Resource/Font/CoreFont/zapfdingbats.pm delete mode 100644 lib/PDF/API2/Resource/Font/Postscript.pm delete mode 100644 lib/PDF/API2/Resource/Font/SynFont.pm delete mode 100644 lib/PDF/API2/Resource/Glyphs.pm delete mode 100644 lib/PDF/API2/Resource/PaperSizes.pm delete mode 100644 lib/PDF/API2/Resource/Pattern.pm delete mode 100644 lib/PDF/API2/Resource/Shading.pm delete mode 100644 lib/PDF/API2/Resource/UniFont.pm delete mode 100644 lib/PDF/API2/Resource/XObject.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/BarCode.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/BarCode/codabar.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/BarCode/code128.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/BarCode/code3of9.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/BarCode/ean13.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/BarCode/int2of5.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Form/Hybrid.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/GD.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/GIF.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/JPEG.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/PNG.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/PNM.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/TIFF.pm delete mode 100644 lib/PDF/API2/Resource/XObject/Image/TIFF/File.pm delete mode 100644 lib/PDF/API2/Resource/uniglyph.txt delete mode 100644 lib/PDF/API2/Simple.pm delete mode 100644 lib/PDF/API2/UniWrap.pm delete mode 100644 lib/PDF/API2/Util.pm delete mode 100644 lib/PDF/API2/Win32.pm delete mode 100644 lib/Return/Value.pm delete mode 100644 lib/Template.pm delete mode 100644 lib/Template/DBI.pod delete mode 100644 lib/Template/FAQ.pod delete mode 100644 lib/Template/Manual.pod delete mode 100644 lib/Template/Manual/Config.pod delete mode 100644 lib/Template/Manual/Credits.pod delete mode 100644 lib/Template/Manual/Directives.pod delete mode 100644 lib/Template/Manual/Filters.pod delete mode 100644 lib/Template/Manual/Internals.pod delete mode 100644 lib/Template/Manual/Intro.pod delete mode 100644 lib/Template/Manual/Plugins.pod delete mode 100644 lib/Template/Manual/Syntax.pod delete mode 100644 lib/Template/Manual/VMethods.pod delete mode 100644 lib/Template/Manual/Variables.pod delete mode 100644 lib/Template/Manual/Views.pod delete mode 100644 lib/Template/Modules.pod delete mode 100644 lib/Template/Plugin.pm delete mode 100644 lib/Template/Plugin/CGI.pm delete mode 100644 lib/Template/Plugin/Datafile.pm delete mode 100644 lib/Template/Plugin/Directory.pm delete mode 100644 lib/Template/Plugin/File.pm delete mode 100644 lib/Template/Plugin/Filter.pm delete mode 100644 lib/Template/Plugin/HTML.pm delete mode 100644 lib/Template/Plugin/Image.pm delete mode 100644 lib/Template/Plugin/String.pm delete mode 100644 lib/Template/Plugin/URL.pm delete mode 100644 lib/Template/Plugin/View.pm delete mode 100644 lib/Template/Plugin/Wrap.pm delete mode 100644 lib/Template/Service.pm delete mode 100644 lib/Template/Stash/XS.pm delete mode 100644 lib/Template/Tiny.pm delete mode 100644 lib/Template/Toolkit.pm delete mode 100644 lib/Template/Tools.pod delete mode 100644 lib/Template/Tools/tpage.pod delete mode 100644 lib/Template/Tools/ttree.pod delete mode 100644 lib/Template/Tutorial.pod delete mode 100644 lib/Template/Tutorial/Datafile.pod delete mode 100644 lib/Template/Tutorial/Web.pod delete mode 100644 lib/sendEmail delete mode 100644 tmpl/page/product/websites.tt diff --git a/.DS_Store b/.DS_Store deleted file mode 100644 index 0ee4e2fb4d2880de9789294bf153ab1d92480026..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6148 zcmeH~F>b>!3`IW^4*{}x?5L#&$PI)bIYBQ_G)AWc3D9=e(fdhpsgpS{icf%iB4xt% zA1o7q?SG~nFap@nop|*yGh;sB8yDPg{+zx}AJ^;Ii?me-Jf)AA?dP^21*Cu!kOERb z3M@#0JjOTM1wE4DHkT9irw zDe%t}u;K7_*z=|GY`uFuufJ#2*Nslbconnect('DBI:'.$self->{dbtype}.':dbname='.$self->{dbname}.';host='.$self->{dbhost},$self->{dbuser},$self->{dbpassword},{PrintError=>0,RaiseError=>0,AutoCommit=>1}) or return $retdata->{error} = "dbquery Connection Error!".$!; $stat = encode("utf8", $stat); - open FILE,">>sql.log"; - print FILE "\n==\n$stat\n==\n"; - close FILE; + # open FILE,">>sql.log"; + # print FILE "\n==\n$stat\n==\n"; + # close FILE; my $sth = $dbh->prepare($stat); diff --git a/apps/api/prefs.cgi b/apps/api/prefs.cgi index 2e197cd..9918fe2 100644 --- a/apps/api/prefs.cgi +++ b/apps/api/prefs.cgi @@ -1,7 +1,7 @@ #!/usr/bin/perl use strict; -use lib ('/home/kilian/perl5/lib/perl5'); +use lib ('../lib'); use CGI; use CGI::Cookie; use CGI::Carp qw/fatalsToBrowser/; diff --git a/apps/api/sqlite.cgi b/apps/api/sqlite.cgi index 7b91678..7160ac3 100644 --- a/apps/api/sqlite.cgi +++ b/apps/api/sqlite.cgi @@ -1,7 +1,7 @@ #!/usr/bin/perl use strict; -use lib ('/home/kilian/perl5/lib/perl5'); +use lib ('../lib'); use CGI; use CGI::Carp; diff --git a/apps/index.cgi b/apps/index.cgi index 77ad989..d975011 100644 --- a/apps/index.cgi +++ b/apps/index.cgi @@ -1,7 +1,7 @@ #!/usr/bin/perl use strict; -use lib ('/home/kilian/perl5/lib/perl5'); +use lib ('./lib'); use lib ('./api/lib'); use File::Basename; use Template; diff --git a/apps/js/apps.js b/apps/js/apps.js index 52ee12a..ee59312 100644 --- a/apps/js/apps.js +++ b/apps/js/apps.js @@ -1,5 +1,5 @@ function logout() { - myurl = ('https:' == document.location.protocol ? 'https' : 'http') + '://'+ location.host + '/dks_lu/apps/'; + myurl = ('https:' == document.location.protocol ? 'https' : 'http') + '://'+ location.host + location.path; $.ajax({ async: false, url: myurl, diff --git a/apps/lib/CGI.pm b/apps/lib/CGI.pm new file mode 100644 index 0000000..297f95e --- /dev/null +++ b/apps/lib/CGI.pm @@ -0,0 +1,3870 @@ +#line 1 "CGI.pm" +package CGI; +require 5.008001; +use if $] >= 5.019, 'deprecate'; +use Carp 'croak'; + +my $appease_cpants_kwalitee = q/ +use strict; +use warnings; +#/; + +$CGI::VERSION='4.35'; + +use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic); + +$_XHTML_DTD = ['-//W3C//DTD XHTML 1.0 Transitional//EN', + 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd']; + +{ + local $^W = 0; + $TAINTED = substr("$0$^X",0,0); +} + +$MOD_PERL = 0; # no mod_perl by default + +#global settings +$POST_MAX = -1; # no limit to uploaded files +$DISABLE_UPLOADS = 0; +$UNLINK_TMP_FILES = 1; +$LIST_CONTEXT_WARN = 1; +$ENCODE_ENTITIES = q{&<>"'}; +$ALLOW_DELETE_CONTENT = 0; + +@SAVED_SYMBOLS = (); + +# >>>>> Here are some globals that you might want to adjust <<<<<< +sub initialize_globals { + # Set this to 1 to generate XTML-compatible output + $XHTML = 1; + + # Change this to the preferred DTD to print in start_html() + # or use default_dtd('text of DTD to use'); + $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN', + 'http://www.w3.org/TR/html4/loose.dtd' ] ; + + # Set this to 1 to enable NOSTICKY scripts + # or: + # 1) use CGI '-nosticky'; + # 2) $CGI::NOSTICKY = 1; + $NOSTICKY = 0; + + # Set this to 1 to enable NPH scripts + # or: + # 1) use CGI qw(-nph) + # 2) CGI::nph(1) + # 3) print header(-nph=>1) + $NPH = 0; + + # Set this to 1 to enable debugging from @ARGV + # Set to 2 to enable debugging from STDIN + $DEBUG = 1; + + # Set this to 1 to generate automatic tab indexes + $TABINDEX = 0; + + # Set this to 1 to cause files uploaded in multipart documents + # to be closed, instead of caching the file handle + # or: + # 1) use CGI qw(:close_upload_files) + # 2) $CGI::close_upload_files(1); + # Uploads with many files run out of file handles. + # Also, for performance, since the file is already on disk, + # it can just be renamed, instead of read and written. + $CLOSE_UPLOAD_FILES = 0; + + # Automatically determined -- don't change + $EBCDIC = 0; + + # Change this to 1 to suppress redundant HTTP headers + $HEADERS_ONCE = 0; + + # separate the name=value pairs by semicolons rather than ampersands + $USE_PARAM_SEMICOLONS = 1; + + # Do not include undefined params parsed from query string + # use CGI qw(-no_undef_params); + $NO_UNDEF_PARAMS = 0; + + # return everything as utf-8 + $PARAM_UTF8 = 0; + + # make param('PUTDATA') act like file upload + $PUTDATA_UPLOAD = 0; + + # Other globals that you shouldn't worry about. + undef $Q; + $BEEN_THERE = 0; + $DTD_PUBLIC_IDENTIFIER = ""; + undef @QUERY_PARAM; + undef %QUERY_PARAM; + undef %EXPORT; + undef $QUERY_CHARSET; + undef %QUERY_FIELDNAMES; + undef %QUERY_TMPFILES; + + # prevent complaints by mod_perl + 1; +} + +# ------------------ START OF THE LIBRARY ------------ + +# make mod_perlhappy +initialize_globals(); + +# FIGURE OUT THE OS WE'RE RUNNING UNDER +# Some systems support the $^O variable. If not +# available then require() the Config library +unless ($OS) { + unless ($OS = $^O) { + require Config; + $OS = $Config::Config{'osname'}; + } +} +if ($OS =~ /^MSWin/i) { + $OS = 'WINDOWS'; +} elsif ($OS =~ /^VMS/i) { + $OS = 'VMS'; +} elsif ($OS =~ /^dos/i) { + $OS = 'DOS'; +} elsif ($OS =~ /^MacOS/i) { + $OS = 'MACINTOSH'; +} elsif ($OS =~ /^os2/i) { + $OS = 'OS2'; +} elsif ($OS =~ /^epoc/i) { + $OS = 'EPOC'; +} elsif ($OS =~ /^cygwin/i) { + $OS = 'CYGWIN'; +} elsif ($OS =~ /^NetWare/i) { + $OS = 'NETWARE'; +} else { + $OS = 'UNIX'; +} + +# Some OS logic. Binary mode enabled on DOS, NT and VMS +$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN|NETWARE)/; + +# This is the default class for the CGI object to use when all else fails. +$DefaultClass = 'CGI' unless defined $CGI::DefaultClass; + +# The path separator is a slash, backslash or semicolon, depending +# on the platform. +$SL = { + UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/', NETWARE => '/', + WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/' + }->{$OS}; + +# This no longer seems to be necessary +# Turn on NPH scripts by default when running under IIS server! +# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; +$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/; + +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Turn on special checking for Doug MacEachern's modperl +# PerlEx::DBI tries to fool DBI by setting MOD_PERL +if (exists $ENV{MOD_PERL} && ! $PERLEX) { + # mod_perl handlers may run system() on scripts using CGI.pm; + # Make sure so we don't get fooled by inherited $ENV{MOD_PERL} + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::Response; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::RequestIO; + require APR::Pool; + } else { + $MOD_PERL = 1; + require Apache; + } +} + +# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning +# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF +# and sometimes CR). The most popular VMS web server +# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't +# use ASCII, so \015\012 means something different. I find this all +# really annoying. +$EBCDIC = "\t" ne "\011"; +if ($OS eq 'VMS') { + $CRLF = "\n"; +} elsif ($EBCDIC) { + $CRLF= "\r\n"; +} else { + $CRLF = "\015\012"; +} + +_set_binmode() if ($needs_binmode); + +sub _set_binmode { + + # rt #57524 - don't set binmode on filehandles if there are + # already none default layers set on them + my %default_layers = ( + unix => 1, + perlio => 1, + stdio => 1, + crlf => 1, + ); + + foreach my $fh ( + \*main::STDOUT, + \*main::STDIN, + \*main::STDERR, + ) { + my @modes = grep { ! $default_layers{$_} } + PerlIO::get_layers( $fh ); + + if ( ! @modes ) { + $CGI::DefaultClass->binmode( $fh ); + } + } +} + +%EXPORT_TAGS = ( + ':html2' => [ 'h1' .. 'h6', qw/ + p br hr ol ul li dl dt dd menu code var strong em + tt u i b blockquote pre img a address cite samp dfn html head + base body Link nextid title meta kbd start_html end_html + input Select option comment charset escapeHTML + / ], + ':html3' => [ qw/ + div table caption th td TR Tr sup Sub strike applet Param nobr + embed basefont style span layer ilayer font frameset frame script small big Area Map + / ], + ':html4' => [ qw/ + abbr acronym bdo col colgroup del fieldset iframe + ins label legend noframes noscript object optgroup Q + thead tbody tfoot + / ], + ':form' => [ qw/ + textfield textarea filefield password_field hidden checkbox checkbox_group + submit reset defaults radio_group popup_menu button autoEscape + scrolling_list image_button start_form end_form + start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART + / ], + ':cgi' => [ qw/ + param multi_param upload path_info path_translated request_uri url self_url script_name + cookie Dump raw_cookie request_method query_string Accept user_agent remote_host content_type + remote_addr referer server_name server_software server_port server_protocol virtual_port + virtual_host remote_ident auth_type http append save_parameters restore_parameters param_fetch + remote_user user_name header redirect import_names put Delete Delete_all url_param cgi_error env_query_string + / ], + ':netscape' => [qw/blink fontsize center/], + ':ssl' => [qw/https/], + ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/], + ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/], + + # bulk export/import + ':html' => [qw/:html2 :html3 :html4 :netscape/], + ':standard' => [qw/:html2 :html3 :html4 :form :cgi :ssl/], + ':all' => [qw/:html2 :html3 :html4 :netscape :form :cgi :ssl :push/] +); + +# to import symbols into caller +sub import { + my $self = shift; + + # This causes modules to clash. + undef %EXPORT_OK; + undef %EXPORT; + + $self->_setup_symbols(@_); + my ($callpack, $callfile, $callline) = caller; + + if ( $callpack eq 'CGI::Fast' ) { + # fixes GH #11 (and GH #12 in CGI::Fast since + # sub import was added to CGI::Fast in 9537f90 + # so we need to move up a level to export the + # routines to the namespace of whatever is using + # CGI::Fast + ($callpack, $callfile, $callline) = caller(1); + } + + # To allow overriding, search through the packages + # Till we find one in which the correct subroutine is defined. + my @packages = ($self,@{"$self\:\:ISA"}); + for $sym (keys %EXPORT) { + my $pck; + my $def = $DefaultClass; + for $pck (@packages) { + if (defined(&{"$pck\:\:$sym"})) { + $def = $pck; + last; + } + } + *{"${callpack}::$sym"} = \&{"$def\:\:$sym"}; + } +} + +sub expand_tags { + my($tag) = @_; + return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/; + my(@r); + return ($tag) unless $EXPORT_TAGS{$tag}; + for (@{$EXPORT_TAGS{$tag}}) { + push(@r,&expand_tags($_)); + } + return @r; +} + +#### Method: new +# The new routine. This will check the current environment +# for an existing query string, and initialize itself, if so. +#### +sub new { + my($class,@initializer) = @_; + my $self = {}; + + bless $self,ref $class || $class || $DefaultClass; + + # always use a tempfile + $self->{'use_tempfile'} = 1; + + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'Apache') + || + UNIVERSAL::isa($initializer[0],'Apache2::RequestRec') + )) { + $self->r(shift @initializer); + } + if (ref($initializer[0]) + && (UNIVERSAL::isa($initializer[0],'CODE'))) { + $self->upload_hook(shift @initializer, shift @initializer); + $self->{'use_tempfile'} = shift @initializer if (@initializer > 0); + } + if ($MOD_PERL) { + if ($MOD_PERL == 1) { + $self->r(Apache->request) unless $self->r; + my $r = $self->r; + $r->register_cleanup(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + } + else { + # XXX: once we have the new API + # will do a real PerlOptions -SetupEnv check + $self->r(Apache2::RequestUtil->request) unless $self->r; + my $r = $self->r; + $r->subprocess_env unless exists $ENV{REQUEST_METHOD}; + $r->pool->cleanup_register(\&CGI::_reset_globals); + $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS; + } + undef $NPH; + } + $self->_reset_globals if $PERLEX; + $self->init(@initializer); + return $self; +} + +sub r { + my $self = shift; + my $r = $self->{'.r'}; + $self->{'.r'} = shift if @_; + $r; +} + +sub upload_hook { + my $self; + if (ref $_[0] eq 'CODE') { + $CGI::Q = $self = $CGI::DefaultClass->new(@_); + } else { + $self = shift; + } + my ($hook,$data,$use_tempfile) = @_; + $self->{'.upload_hook'} = $hook; + $self->{'.upload_data'} = $data; + $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile; +} + +#### Method: param / multi_param +# Returns the value(s)of a named parameter. +# If invoked in a list context, returns the +# entire list. Otherwise returns the first +# member of the list. +# If name is not provided, return a list of all +# the known parameters names available. +# If more than one argument is provided, the +# second and subsequent arguments are used to +# set the value of the parameter. +# +# note that calling param() in list context +# will raise a warning about potential bad +# things, hence the multi_param method +#### +sub multi_param { + # we don't need to set $LIST_CONTEXT_WARN to 0 here + # because param() will check the caller before warning + my @list_of_params = param( @_ ); + return @list_of_params; +} + +sub param { + my($self,@p) = self_or_default(@_); + + return $self->all_parameters unless @p; + + # list context can be dangerous so warn: + # http://blog.gerv.net/2014.10/new-class-of-vulnerability-in-perl-web-applications + if ( wantarray && $LIST_CONTEXT_WARN == 1 ) { + my ( $package, $filename, $line ) = caller; + if ( $package ne 'CGI' ) { + $LIST_CONTEXT_WARN++; # only warn once + warn "CGI::param called in list context from $filename line $line, this can lead to vulnerabilities. " + . 'See the warning in "Fetching the value or values of a single named parameter"'; + } + } + + my($name,$value,@other); + + # For compatibility between old calling style and use_named_parameters() style, + # we have to special case for a single parameter present. + if (@p > 1) { + ($name,$value,@other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]],@p); + my(@values); + + if (substr($p[0],0,1) eq '-') { + @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : (); + } else { + for ($value,@other) { + push(@values,$_) if defined($_); + } + } + # If values is provided, then we set it. + if (@values or defined $value) { + $self->add_parameter($name); + $self->{param}{$name}=[@values]; + } + } else { + $name = $p[0]; + } + + return unless defined($name) && $self->{param}{$name}; + + my @result = @{$self->{param}{$name}}; + + if ($PARAM_UTF8 && $name ne 'PUTDATA' && $name ne 'POSTDATA') { + eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions + @result = map {ref $_ ? $_ : $self->_decode_utf8($_) } @result; + } + + return wantarray ? @result : $result[0]; +} + +sub _decode_utf8 { + my ($self, $val) = @_; + + if (Encode::is_utf8($val)) { + return $val; + } + else { + return Encode::decode(utf8 => $val); + } +} + +sub self_or_default { + return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI'); + unless (defined($_[0]) && + (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case + ) { + $Q = $CGI::DefaultClass->new unless defined($Q); + unshift(@_,$Q); + } + return wantarray ? @_ : $Q; +} + +sub self_or_CGI { + local $^W=0; # prevent a warning + if (defined($_[0]) && + (substr(ref($_[0]),0,3) eq 'CGI' + || UNIVERSAL::isa($_[0],'CGI'))) { + return @_; + } else { + return ($DefaultClass,@_); + } +} + +######################################## +# THESE METHODS ARE MORE OR LESS PRIVATE +# GO TO THE __DATA__ SECTION TO SEE MORE +# PUBLIC METHODS +######################################## + +# Initialize the query object from the environment. +# If a parameter list is found, this object will be set +# to a hash in which parameter names are keys +# and the values are stored as lists +# If a keyword list is found, this method creates a bogus +# parameter list with the single parameter 'keywords'. + +sub init { + my $self = shift; + my($query_string,$meth,$content_length,$fh,@lines) = ('','','',''); + + my $is_xforms; + + my $initializer = shift; # for backward compatibility + local($/) = "\n"; + + # set autoescaping on by default + $self->{'escape'} = 1; + + # if we get called more than once, we want to initialize + # ourselves from the original query (which may be gone + # if it was read from STDIN originally.) + if (@QUERY_PARAM && !defined($initializer)) { + for my $name (@QUERY_PARAM) { + my $val = $QUERY_PARAM{$name}; # always an arrayref; + $self->param('-name'=>$name,'-value'=> $val); + if (defined $val and ref $val eq 'ARRAY') { + for my $fh (grep {defined($_) && ref($_) && defined(fileno($_))} @$val) { + seek($fh,0,0); # reset the filehandle. + } + + } + } + $self->charset($QUERY_CHARSET); + $self->{'.fieldnames'} = {%QUERY_FIELDNAMES}; + $self->{'.tmpfiles'} = {%QUERY_TMPFILES}; + return; + } + + $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'}); + $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0; + + $fh = to_filehandle($initializer) if $initializer; + + # set charset to the safe ISO-8859-1 + $self->charset('ISO-8859-1'); + + METHOD: { + + # avoid unreasonably large postings + if (($POST_MAX > 0) && ($content_length > $POST_MAX)) { + #discard the post, unread + $self->cgi_error("413 Request entity too large"); + last METHOD; + } + + # Process multipart postings, but only if the initializer is + # not defined. + if ($meth eq 'POST' + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data| + && !defined($initializer) + ) { + my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/; + $self->read_multipart($boundary,$content_length); + last METHOD; + } + + # Process XForms postings. We know that we have XForms in the + # following cases: + # method eq 'POST' && content-type eq 'application/xml' + # method eq 'POST' && content-type =~ /multipart\/related.+start=/ + # There are more cases, actually, but for now, we don't support other + # methods for XForm posts. + # In a XForm POST, the QUERY_STRING is parsed normally. + # If the content-type is 'application/xml', we just set the param + # XForms:Model (referring to the xml syntax) param containing the + # unparsed XML data. + # In the case of multipart/related we set XForms:Model as above, but + # the other parts are available as uploads with the Content-ID as the + # the key. + # See the URL below for XForms specs on this issue. + # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options + if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) { + if ($ENV{'CONTENT_TYPE'} eq 'application/xml') { + my($param) = 'XForms:Model'; + my($value) = ''; + $self->add_parameter($param); + $self->read_from_client(\$value,$content_length,0) + if $content_length > 0; + push (@{$self->{param}{$param}},$value); + $is_xforms = 1; + } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\]+)\>?\"?/) { + my($boundary,$start) = ($1,$2); + my($param) = 'XForms:Model'; + $self->add_parameter($param); + my($value) = $self->read_multipart_related($start,$boundary,$content_length,0); + push (@{$self->{param}{$param}},$value); + $query_string = $self->_get_query_string_from_env; + $is_xforms = 1; + } + } + + + # If initializer is defined, then read parameters + # from it. + if (!$is_xforms && defined($initializer)) { + if (UNIVERSAL::isa($initializer,'CGI')) { + $query_string = $initializer->query_string; + last METHOD; + } + if (ref($initializer) && ref($initializer) eq 'HASH') { + for (keys %$initializer) { + $self->param('-name'=>$_,'-value'=>$initializer->{$_}); + } + last METHOD; + } + + if (defined($fh) && ($fh ne '')) { + while (my $line = <$fh>) { + chomp $line; + last if $line =~ /^=$/; + push(@lines,$line); + } + # massage back into standard format + if ("@lines" =~ /=/) { + $query_string=join("&",@lines); + } else { + $query_string=join("+",@lines); + } + last METHOD; + } + + # last chance -- treat it as a string + $initializer = $$initializer if ref($initializer) eq 'SCALAR'; + $query_string = $initializer; + + last METHOD; + } + + # If method is GET, HEAD or DELETE, fetch the query from + # the environment. + if ($is_xforms || $meth=~/^(GET|HEAD|DELETE)$/) { + $query_string = $self->_get_query_string_from_env; + $self->param($meth . 'DATA', $self->param('XForms:Model')) + if $is_xforms; + last METHOD; + } + + if ($meth eq 'POST' || $meth eq 'PUT') { + if ( $content_length > 0 ) { + if ( ( $PUTDATA_UPLOAD || $self->{'.upload_hook'} ) && !$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ){ + my $postOrPut = $meth . 'DATA' ; # POSTDATA/PUTDATA + $self->read_postdata_putdata( $postOrPut, $content_length, $ENV{'CONTENT_TYPE'} ); + $meth = ''; # to skip xform testing + undef $query_string ; + } else { + $self->read_from_client(\$query_string,$content_length,0); + } + } + # Some people want to have their cake and eat it too! + # Uncomment this line to have the contents of the query string + # APPENDED to the POST data. + # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'}; + last METHOD; + } + + # If $meth is not of GET, POST, PUT or HEAD, assume we're + # being debugged offline. + # Check the command line and then the standard input for data. + # We use the shellwords package in order to behave the way that + # UN*X programmers expect. + if ($DEBUG) + { + my $cmdline_ret = read_from_cmdline(); + $query_string = $cmdline_ret->{'query_string'}; + if (defined($cmdline_ret->{'subpath'})) + { + $self->path_info($cmdline_ret->{'subpath'}); + } + } + } + +# YL: Begin Change for XML handler 10/19/2001 + if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT') + && defined($ENV{'CONTENT_TYPE'}) + && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| + && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) { + my($param) = $meth . 'DATA' ; + $self->add_parameter($param) ; + push (@{$self->{param}{$param}},$query_string); + undef $query_string ; + } +# YL: End Change for XML handler 10/19/2001 + + # We now have the query string in hand. We do slightly + # different things for keyword lists and parameter lists. + if (defined $query_string && length $query_string) { + if ($query_string =~ /[&=;]/) { + $self->parse_params($query_string); + } else { + $self->add_parameter('keywords'); + $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)]; + } + } + + # Special case. Erase everything if there is a field named + # .defaults. + if ($self->param('.defaults')) { + $self->delete_all(); + } + + # hash containing our defined fieldnames + $self->{'.fieldnames'} = {}; + for ($self->param('.cgifields')) { + $self->{'.fieldnames'}->{$_}++; + } + + # Clear out our default submission button flag if present + $self->delete('.submit'); + $self->delete('.cgifields'); + + $self->save_request unless defined $initializer; +} + +sub _get_query_string_from_env { + my $self = shift; + my $query_string = ''; + + if ( $MOD_PERL ) { + $query_string = $self->r->args; + if ( ! $query_string && $MOD_PERL == 2 ) { + # possibly a redirect, inspect prev request + # (->prev only supported under mod_perl2) + if ( my $prev = $self->r->prev ) { + $query_string = $prev->args; + } + } + } + + $query_string ||= $ENV{'QUERY_STRING'} + if defined $ENV{'QUERY_STRING'}; + + if ( ! $query_string ) { + # try to get from REDIRECT_ env variables, support + # 5 levels of redirect and no more (RT #36312) + REDIRECT: foreach my $r ( 1 .. 5 ) { + my $key = join( '',( 'REDIRECT_' x $r ) ); + $query_string ||= $ENV{"${key}QUERY_STRING"} + if defined $ENV{"${key}QUERY_STRING"}; + last REDIRECT if $query_string; + } + } + + return $query_string; +} + +# FUNCTIONS TO OVERRIDE: +# Turn a string into a filehandle +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; +} + +# send output to the browser +sub put { + my($self,@p) = self_or_default(@_); + $self->print(@p); +} + +# print to standard output (for overriding in mod_perl) +sub print { + shift; + CORE::print(@_); +} + +# get/set last cgi_error +sub cgi_error { + my ($self,$err) = self_or_default(@_); + $self->{'.cgi_error'} = $err if defined $err; + return $self->{'.cgi_error'}; +} + +sub save_request { + my($self) = @_; + # We're going to play with the package globals now so that if we get called + # again, we initialize ourselves in exactly the same way. This allows + # us to have several of these objects. + @QUERY_PARAM = $self->param; # save list of parameters + for (@QUERY_PARAM) { + next unless defined $_; + $QUERY_PARAM{$_}=$self->{param}{$_}; + } + $QUERY_CHARSET = $self->charset; + %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}}; + %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} }; +} + +sub parse_params { + my($self,$tosplit) = @_; + my(@pairs) = split(/[&;]/,$tosplit); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next unless defined $param; + next if $NO_UNDEF_PARAMS and not defined $value; + $value = '' unless defined $value; + $param = unescape($param); + $value = unescape($value); + $self->add_parameter($param); + push (@{$self->{param}{$param}},$value); + } +} + +sub add_parameter { + my($self,$param)=@_; + return unless defined $param; + push (@{$self->{'.parameters'}},$param) + unless defined($self->{param}{$param}); +} + +sub all_parameters { + my $self = shift; + return () unless defined($self) && $self->{'.parameters'}; + return () unless @{$self->{'.parameters'}}; + return @{$self->{'.parameters'}}; +} + +# put a filehandle into binary mode (DOS) +sub binmode { + return unless defined($_[1]) && ref ($_[1]) && defined fileno($_[1]); + CORE::binmode($_[1]); +} + +# back compatibility html tag generation functions - noop +# since this is now the default having removed AUTOLOAD +sub compile { 1; } + +sub _all_html_tags { + return qw/ + a abbr acronym address applet Area + b base basefont bdo big blink blockquote body br + caption center cite code col colgroup + dd del dfn div dl dt + em embed + fieldset font fontsize frame frameset + h1 h2 h3 h4 h5 h6 head hr html + i iframe ilayer img input ins + kbd + label layer legend li Link + Map menu meta + nextid nobr noframes noscript + object ol option + p Param pre + Q + samp script Select small span + strike strong style Sub sup + table tbody td tfoot th thead title Tr TR tt + u ul + var + / +} + +foreach my $tag ( _all_html_tags() ) { + *$tag = sub { return _tag_func($tag,@_); }; + + # start_html and end_html already exist as custom functions + next if ($tag eq 'html'); + + foreach my $start_end ( qw/ start end / ) { + my $start_end_function = "${start_end}_${tag}"; + *$start_end_function = sub { return _tag_func($start_end_function,@_); }; + } +} + +sub _tag_func { + my $tagname = shift; + my ($q,$a,@rest) = self_or_default(@_); + + my($attr) = ''; + + if (ref($a) && ref($a) eq 'HASH') { + my(@attr) = make_attributes($a,$q->{'escape'}); + $attr = " @attr" if @attr; + } else { + unshift @rest,$a if defined $a; + } + + $tagname = lc( $tagname ); + + if ($tagname=~/start_(\w+)/i) { + return "<$1$attr>"; + } elsif ($tagname=~/end_(\w+)/i) { + return ""; + } else { + return $XHTML ? "<$tagname$attr />" : "<$tagname$attr>" unless @rest; + my($tag,$untag) = ("<$tagname$attr>",""); + my @result = map { "$tag$_$untag" } + (ref($rest[0]) eq 'ARRAY') ? @{$rest[0]} : "@rest"; + return "@result"; + } +} + +sub _selected { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(selected="selected" ) : qq(selected ); +} + +sub _checked { + my $self = shift; + my $value = shift; + return '' unless $value; + return $XHTML ? qq(checked="checked" ) : qq(checked ); +} + +sub _reset_globals { initialize_globals(); } + +sub _setup_symbols { + my $self = shift; + + # to avoid reexporting unwanted variables + undef %EXPORT; + + for (@_) { + + if ( /^[:-]any$/ ) { + warn "CGI -any pragma has been REMOVED. You should audit your code for any use " + . "of none supported / incorrectly spelled tags and remove them" + ; + next; + } + $HEADERS_ONCE++, next if /^[:-]unique_headers$/; + $NPH++, next if /^[:-]nph$/; + $NOSTICKY++, next if /^[:-]nosticky$/; + $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/; + $DEBUG=2, next if /^[:-][Dd]ebug$/; + $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/; + $PUTDATA_UPLOAD++, next if /^[:-](?:putdata_upload|postdata_upload)$/; + $PARAM_UTF8++, next if /^[:-]utf8$/; + $XHTML++, next if /^[:-]xhtml$/; + $XHTML=0, next if /^[:-]no_?xhtml$/; + $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/; + $TABINDEX++, next if /^[:-]tabindex$/; + $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/; + $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/; + + for (&expand_tags($_)) { + tr/a-zA-Z0-9_//cd; # don't allow weird function names + $EXPORT{$_}++; + } + } + @SAVED_SYMBOLS = @_; +} + +sub charset { + my ($self,$charset) = self_or_default(@_); + $self->{'.charset'} = $charset if defined $charset; + $self->{'.charset'}; +} + +sub element_id { + my ($self,$new_value) = self_or_default(@_); + $self->{'.elid'} = $new_value if defined $new_value; + sprintf('%010d',$self->{'.elid'}++); +} + +sub element_tab { + my ($self,$new_value) = self_or_default(@_); + $self->{'.etab'} ||= 1; + $self->{'.etab'} = $new_value if defined $new_value; + my $tab = $self->{'.etab'}++; + return '' unless $TABINDEX or defined $new_value; + return qq(tabindex="$tab" ); +} + +##### +# subroutine: read_postdata_putdata +# +# Unless file uploads are disabled +# Reads BODY of POST/PUT request and stuffs it into tempfile +# accessible as param POSTDATA/PUTDATA +# +# Also respects upload_hook +# +# based on subroutine read_multipart_related +##### +sub read_postdata_putdata { + my ( $self, $postOrPut, $content_length, $content_type ) = @_; + my %header = ( + "Content-Type" => $content_type, + ); + my $param = $postOrPut; + # add this parameter to our list + $self->add_parameter($param); + + + UPLOADS: { + + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + + # while (defined($data = $buffer->read)) { } + my $buff; + my $unit = $CGI::MultipartBuffer::INITIAL_FILLUNIT; + my $len = $content_length; + while ( $len > 0 ) { + my $read = $self->read_from_client( \$buf, $unit, 0 ); + $len -= $read; + } + last UPLOADS; + } + + # SHOULD PROBABLY SKIP THIS IF NOT $self->{'use_tempfile'} + # BUT THE REST OF CGI.PM DOESN'T, SO WHATEVER + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $postOrPut ); + + $CGI::DefaultClass->binmode($filehandle) + if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local ($\) = ''; + my $totalbytes; + my $unit = $CGI::MultipartBuffer::INITIAL_FILLUNIT; + my $len = $content_length; + $unit = $len; + my $ZERO_LOOP_COUNTER =0; + + while( $len > 0 ) + { + + my $bytesRead = $self->read_from_client( \$data, $unit, 0 ); + $len -= $bytesRead ; + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead <= 0) { + die "CGI.pm: Server closed socket during read_postdata_putdata (client aborted?).\n" if $ZERO_LOOP_COUNTER++ >= $SPIN_LOOP_MAX; + } else { + $ZERO_LOOP_COUNTER = 0; + } + + if ( defined $self->{'.upload_hook'} ) { + $totalbytes += length($data); + &{ $self->{'.upload_hook'} }( $param, $data, $totalbytes, + $self->{'.upload_data'} ); + } + print $filehandle $data if ( $self->{'use_tempfile'} ); + undef $data; + } + + # back up to beginning of file + seek( $filehandle, 0, 0 ); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push( @{ $self->{param}{$param} }, $filehandle ); + } + return; +} + +sub URL_ENCODED { 'application/x-www-form-urlencoded'; } + +sub MULTIPART { 'multipart/form-data'; } + +sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; } + +# Create a new multipart buffer +sub new_MultipartBuffer { + my($self,$boundary,$length) = @_; + return CGI::MultipartBuffer->new($self,$boundary,$length); +} + +# Read data from a file handle +sub read_from_client { + my($self, $buff, $len, $offset) = @_; + local $^W=0; # prevent a warning + return $MOD_PERL + ? $self->r->read($$buff, $len, $offset) + : read(\*STDIN, $$buff, $len, $offset); +} + +#### Method: delete +# Deletes the named parameter entirely. +#### +sub delete { + my($self,@p) = self_or_default(@_); + my(@names) = rearrange([NAME],@p); + my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names; + my %to_delete; + for my $name (@to_delete) + { + CORE::delete $self->{param}{$name}; + CORE::delete $self->{'.fieldnames'}->{$name}; + $to_delete{$name}++; + } + @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param(); + return; +} + +#### Method: import_names +# Import all parameters into the given namespace. +# Assumes namespace 'Q' if not specified +#### +sub import_names { + my($self,$namespace,$delete) = self_or_default(@_); + $namespace = 'Q' unless defined($namespace); + die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::; + if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) { + # can anyone find an easier way to do this? + for (keys %{"${namespace}::"}) { + local *symbol = "${namespace}::${_}"; + undef $symbol; + undef @symbol; + undef %symbol; + } + } + my($param,@value,$var); + for $param ($self->param) { + # protect against silly names + ($var = $param)=~tr/a-zA-Z0-9_/_/c; + $var =~ s/^(?=\d)/_/; + local *symbol = "${namespace}::$var"; + @value = $self->param($param); + @symbol = @value; + $symbol = $value[0]; + } +} + +#### Method: keywords +# Keywords acts a bit differently. Calling it in a list context +# returns the list of keywords. +# Calling it in a scalar context gives you the size of the list. +#### +sub keywords { + my($self,@values) = self_or_default(@_); + # If values is provided, then we set it. + $self->{param}{'keywords'}=[@values] if @values; + my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : (); + @result; +} + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +sub Vars { + my $q = shift; + my %in; + tie(%in,CGI,$q); + return %in if wantarray; + return \%in; +} + +# These are some tie() interfaces for compatibility +# with Steve Brenner's cgi-lib.pl routines +sub ReadParse { + local(*in); + if (@_) { + *in = $_[0]; + } else { + my $pkg = caller(); + *in=*{"${pkg}::in"}; + } + tie(%in,CGI); + return scalar(keys %in); +} + +sub PrintHeader { + my($self) = self_or_default(@_); + return $self->header(); +} + +sub HtmlTop { + my($self,@p) = self_or_default(@_); + return $self->start_html(@p); +} + +sub HtmlBot { + my($self,@p) = self_or_default(@_); + return $self->end_html(@p); +} + +sub SplitParam { + my ($param) = @_; + my (@params) = split ("\0", $param); + return (wantarray ? @params : $params[0]); +} + +sub MethGet { + return request_method() eq 'GET'; +} + +sub MethPost { + return request_method() eq 'POST'; +} + +sub MethPut { + return request_method() eq 'PUT'; +} + +sub TIEHASH { + my $class = shift; + my $arg = $_[0]; + if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) { + return $arg; + } + return $Q ||= $class->new(@_); +} + +sub STORE { + my $self = shift; + my $tag = shift; + my $vals = shift; + my @vals = defined($vals) && index($vals,"\0")!=-1 ? split("\0",$vals) : $vals; + $self->param(-name=>$tag,-value=>\@vals); +} + +sub FETCH { + return $_[0] if $_[1] eq 'CGI'; + return undef unless defined $_[0]->param($_[1]); + return join("\0",$_[0]->param($_[1])); +} + +sub FIRSTKEY { + $_[0]->{'.iterator'}=0; + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} + +sub NEXTKEY { + $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++]; +} + +sub EXISTS { + exists $_[0]->{param}{$_[1]}; +} + +sub DELETE { + my ($self, $param) = @_; + my $value = $self->FETCH($param); + $self->delete($param); + return $value; +} + +sub CLEAR { + %{$_[0]}=(); +} +#### + +#### +# Append a new value to an existing query +#### +sub append { + my($self,@p) = self_or_default(@_); + my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p); + my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : (); + if (@values) { + $self->add_parameter($name); + push(@{$self->{param}{$name}},@values); + } + return $self->param($name); +} + +#### Method: delete_all +# Delete all parameters +#### +sub delete_all { + my($self) = self_or_default(@_); + my @param = $self->param(); + $self->delete(@param); +} + +sub Delete { + my($self,@p) = self_or_default(@_); + $self->delete(@p); +} + +sub Delete_all { + my($self,@p) = self_or_default(@_); + $self->delete_all(@p); +} + +#### Method: autoescape +# If you want to turn off the autoescaping features, +# call this method with undef as the argument +sub autoEscape { + my($self,$escape) = self_or_default(@_); + my $d = $self->{'escape'}; + $self->{'escape'} = $escape; + $d; +} + +#### Method: version +# Return the current version +#### +sub version { + return $VERSION; +} + +#### Method: url_param +# Return a parameter in the QUERY_STRING, regardless of +# whether this was a POST or a GET +#### +sub url_param { + my ($self,@p) = self_or_default(@_); + my $name = shift(@p); + return undef unless exists($ENV{QUERY_STRING}); + unless (exists($self->{'.url_param'})) { + $self->{'.url_param'}={}; # empty hash + if ($ENV{QUERY_STRING} =~ /=/) { + my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING}); + my($param,$value); + for (@pairs) { + ($param,$value) = split('=',$_,2); + next if ! defined($param); + $param = unescape($param); + $value = unescape($value); + push(@{$self->{'.url_param'}->{$param}},$value); + } + } else { + my @keywords = $self->parse_keywordlist($ENV{QUERY_STRING}); + $self->{'.url_param'}{'keywords'} = \@keywords if @keywords; + } + } + return keys %{$self->{'.url_param'}} unless defined($name); + return () unless $self->{'.url_param'}->{$name}; + return wantarray ? @{$self->{'.url_param'}->{$name}} + : $self->{'.url_param'}->{$name}->[0]; +} + +#### Method: Dump +# Returns a string in which all the known parameter/value +# pairs are represented as nested lists, mainly for the purposes +# of debugging. +#### +sub Dump { + my($self) = self_or_default(@_); + my($param,$value,@result); + return '
    ' unless $self->param; + push(@result,"
      "); + for $param ($self->param) { + my($name)=$self->_maybe_escapeHTML($param); + push(@result,"
    • $name
      • "); + push(@result,"
        "); + for $value ($self->param($param)) { + $value = $self->_maybe_escapeHTML($value); + $value =~ s/\n/
        \n/g; + push(@result,"
      • $value
        • "); + } + push(@result,"
      "); + } + push(@result,"
    "); + return join("\n",@result); +} + +#### Method as_string +# +# synonym for "dump" +#### +sub as_string { + &Dump(@_); +} + +#### Method: save +# Write values out to a filehandle in such a way that they can +# be reinitialized by the filehandle form of the new() method +#### +sub save { + my($self,$filehandle) = self_or_default(@_); + $filehandle = to_filehandle($filehandle); + my($param); + local($,) = ''; # set print field separator back to a sane value + local($\) = ''; # set output line separator to a sane value + for $param ($self->param) { + my($escaped_param) = escape($param); + my($value); + for $value ($self->param($param)) { + print $filehandle "$escaped_param=",escape("$value"),"\n" + if length($escaped_param) or length($value); + } + } + for (keys %{$self->{'.fieldnames'}}) { + print $filehandle ".cgifields=",escape("$_"),"\n"; + } + print $filehandle "=\n"; # end of record +} + +#### Method: save_parameters +# An alias for save() that is a better name for exportation. +# Only intended to be used with the function (non-OO) interface. +#### +sub save_parameters { + my $fh = shift; + return save(to_filehandle($fh)); +} + +#### Method: restore_parameters +# A way to restore CGI parameters from an initializer. +# Only intended to be used with the function (non-OO) interface. +#### +sub restore_parameters { + $Q = $CGI::DefaultClass->new(@_); +} + +#### Method: multipart_init +# Return a Content-Type: style header for server-push +# This has to be NPH on most web servers, and it is advisable to set $| = 1 +# +# Many thanks to Ed Jordan for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_init { + my($self,@p) = self_or_default(@_); + my($boundary,$charset,@other) = rearrange_header([BOUNDARY,CHARSET],@p); + if (!$boundary) { + $boundary = '------- =_'; + my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z'); + for (1..17) { + $boundary .= $chrs[rand(scalar @chrs)]; + } + } + + $self->{'separator'} = "$CRLF--$boundary$CRLF"; + $self->{'final_separator'} = "$CRLF--$boundary--$CRLF"; + $type = SERVER_PUSH($boundary); + return $self->header( + -nph => 0, + -type => $type, + -charset => $charset, + (map { split "=", $_, 2 } @other), + ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end; +} + +#### Method: multipart_start +# Return a Content-Type: style header for server-push, start of section +# +# Many thanks to Ed Jordan for this +# contribution, updated by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_start { + my(@header); + my($self,@p) = self_or_default(@_); + my($type,$charset,@other) = rearrange([TYPE,CHARSET],@p); + $type = $type || 'text/html'; + if ($charset) { + push(@header,"Content-Type: $type; charset=$charset"); + } else { + push(@header,"Content-Type: $type"); + } + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/; + ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e; + } + push(@header,@other); + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + return $header; +} + +#### Method: multipart_end +# Return a MIME boundary separator for server-push, end of section +# +# Many thanks to Ed Jordan for this +# contribution +#### +sub multipart_end { + my($self,@p) = self_or_default(@_); + return $self->{'separator'}; +} + +#### Method: multipart_final +# Return a MIME boundary separator for server-push, end of all sections +# +# Contributed by Andrew Benham (adsb@bigfoot.com) +#### +sub multipart_final { + my($self,@p) = self_or_default(@_); + return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF; +} + +#### Method: header +# Return a Content-Type: style header +# +#### +sub header { + my($self,@p) = self_or_default(@_); + my(@header); + + return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE; + + my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) = + rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'], + 'STATUS',['COOKIE','COOKIES','SET-COOKIE'],'TARGET', + 'EXPIRES','NPH','CHARSET', + 'ATTACHMENT','P3P'],@p); + + # Since $cookie and $p3p may be array references, + # we must stringify them before CR escaping is done. + my @cookie; + for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) { + my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_; + push(@cookie,$cs) if defined $cs and $cs ne ''; + } + $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY'; + + # CR escaping for values, per RFC 822 + for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) { + if (defined $header) { + # From RFC 822: + # Unfolding is accomplished by regarding CRLF immediately + # followed by a LWSP-char as equivalent to the LWSP-char. + $header =~ s/$CRLF(\s)/$1/g; + + # All other uses of newlines are invalid input. + if ($header =~ m/$CRLF|\015|\012/) { + # shorten very long values in the diagnostic + $header = substr($header,0,72).'...' if (length $header > 72); + die "Invalid header value contains a newline not followed by whitespace: $header"; + } + } + } + + $nph ||= $NPH; + + $type ||= 'text/html' unless defined($type); + + # sets if $charset is given, gets if not + $charset = $self->charset( $charset ); + + # rearrange() was designed for the HTML portion, so we + # need to fix it up a little. + for (@other) { + # Don't use \s because of perl bug 21951 + next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s; + ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e; + } + + $type .= "; charset=$charset" + if $type ne '' + and $type !~ /\bcharset\b/ + and defined $charset + and $charset ne ''; + + # Maybe future compatibility. Maybe not. + my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0'; + push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph; + push(@header,"Server: " . &server_software()) if $nph; + + push(@header,"Status: $status") if $status; + push(@header,"Window-Target: $target") if $target; + push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p; + # push all the cookies -- there may be several + push(@header,map {"Set-Cookie: $_"} @cookie); + # if the user indicates an expiration time, then we need + # both an Expires and a Date header (so that the browser is + # uses OUR clock) + push(@header,"Expires: " . expires($expires,'http')) + if $expires; + push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph; + push(@header,"Pragma: no-cache") if $self->cache(); + push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment; + push(@header,map {ucfirst $_} @other); + push(@header,"Content-Type: $type") if $type ne ''; + my $header = join($CRLF,@header)."${CRLF}${CRLF}"; + if (($MOD_PERL >= 1) && !$nph) { + $self->r->send_cgi_header($header); + return ''; + } + return $header; +} + +#### Method: cache +# Control whether header() will produce the no-cache +# Pragma directive. +#### +sub cache { + my($self,$new_value) = self_or_default(@_); + $new_value = '' unless $new_value; + if ($new_value ne '') { + $self->{'cache'} = $new_value; + } + return $self->{'cache'}; +} + +#### Method: redirect +# Return a Location: style header +# +#### +sub redirect { + my($self,@p) = self_or_default(@_); + my($url,$target,$status,$cookie,$nph,@other) = + rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES','SET-COOKIE'],NPH],@p); + $status = '302 Found' unless defined $status; + $url ||= $self->self_url; + my(@o); + for (@other) { tr/\"//d; push(@o,split("=",$_,2)); } + unshift(@o, + '-Status' => $status, + '-Location'=> $url, + '-nph' => $nph); + unshift(@o,'-Target'=>$target) if $target; + unshift(@o,'-Type'=>''); + my @unescaped; + unshift(@unescaped,'-Cookie'=>$cookie) if $cookie; + return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped); +} + +#### Method: start_html +# Canned HTML header +# +# Parameters: +# $title -> (optional) The title for this HTML document (-title) +# $author -> (optional) e-mail address of the author (-author) +# $base -> (optional) if set to true, will enter the BASE address of this document +# for resolving relative references (-base) +# $xbase -> (optional) alternative base at some remote location (-xbase) +# $target -> (optional) target window to load all links into (-target) +# $script -> (option) Javascript code (-script) +# $no_script -> (option) Javascript +END + ; + my($other) = @other ? " @other" : ''; + push(@result,"\n\n"); + return join("\n",@result); +} + +### Method: _style +# internal method for generating a CSS style section +#### +sub _style { + my ($self,$style) = @_; + my (@result); + + my $type = 'text/css'; + my $rel = 'stylesheet'; + + + my $cdata_start = $XHTML ? "\n\n" : " -->\n"; + + my @s = ref($style) eq 'ARRAY' ? @$style : $style; + my $other = ''; + + for my $s (@s) { + if (ref($s)) { + my($src,$code,$verbatim,$stype,$alternate,$foo,@other) = + rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)], + ('-foo'=>'bar', + ref($s) eq 'ARRAY' ? @$s : %$s)); + my $type = defined $stype ? $stype : 'text/css'; + my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet'; + $other = "@other" if @other; + + if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference + { # If it is, push a LINK tag for each one + for $src (@$src) + { + push(@result,$XHTML ? qq() + : qq()) if $src; + } + } + else + { # Otherwise, push the single -src, if it exists. + push(@result,$XHTML ? qq() + : qq() + ) if $src; + } + if ($verbatim) { + my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim; + push(@result, "") for @v; + } + if ($code) { + my @c = ref($code) eq 'ARRAY' ? @$code : $code; + push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c; + } + + } else { + my $src = $s; + push(@result,$XHTML ? qq() + : qq()); + } + } + @result; +} + +sub _script { + my ($self,$script) = @_; + my (@result); + + my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script); + for $script (@scripts) { + my($src,$code,$language,$charset); + if (ref($script)) { # script is a hash + ($src,$code,$type,$charset) = + rearrange(['SRC','CODE',['LANGUAGE','TYPE'],'CHARSET'], + '-foo'=>'bar', # a trick to allow the '-' to be omitted + ref($script) eq 'ARRAY' ? @$script : %$script); + $type ||= 'text/javascript'; + unless ($type =~ m!\w+/\w+!) { + $type =~ s/[\d.]+$//; + $type = "text/$type"; + } + } else { + ($src,$code,$type,$charset) = ('',$script, 'text/javascript', ''); + } + + my $comment = '//'; # javascript by default + $comment = '#' if $type=~/perl|tcl/i; + $comment = "'" if $type=~/vbscript/i; + + my ($cdata_start,$cdata_end); + if ($XHTML) { + $cdata_start = "$comment"; + } else { + $cdata_start = "\n\n"; + } + my(@satts); + push(@satts,'src'=>$src) if $src; + push(@satts,'type'=>$type); + push(@satts,'charset'=>$charset) if ($src && $charset); + $code = $cdata_start . $code . $cdata_end if defined $code; + push(@result,$self->script({@satts},$code || '')); + } + @result; +} + +#### Method: end_html +# End an HTML document. +# Trivial method for completeness. Just returns "" +#### +sub end_html { + return "\n\n"; +} + +################################ +# METHODS USED IN BUILDING FORMS +################################ + +#### Method: isindex +# Just prints out the isindex tag. +# Parameters: +# $action -> optional URL of script to run +# Returns: +# A string containing a tag +sub isindex { + my($self,@p) = self_or_default(@_); + my($action,@other) = rearrange([ACTION],@p); + $action = qq/ action="$action"/ if $action; + my($other) = @other ? " @other" : ''; + return $XHTML ? "" : ""; +} + +#### Method: start_form +# Start a form +# Parameters: +# $method -> optional submission method to use (GET or POST) +# $action -> optional URL of script to run +# $enctype ->encoding to use (URL_ENCODED or MULTIPART) +sub start_form { + my($self,@p) = self_or_default(@_); + + my($method,$action,$enctype,@other) = + rearrange([METHOD,ACTION,ENCTYPE],@p); + + $method = $self->_maybe_escapeHTML(lc($method || 'post')); + + if( $XHTML ){ + $enctype = $self->_maybe_escapeHTML($enctype || &MULTIPART); + }else{ + $enctype = $self->_maybe_escapeHTML($enctype || &URL_ENCODED); + } + + if (defined $action) { + $action = $self->_maybe_escapeHTML($action); + } + else { + $action = $self->_maybe_escapeHTML($self->request_uri || $self->self_url); + } + $action = qq(action="$action"); + my($other) = @other ? " @other" : ''; + $self->{'.parametersToAdd'}={}; + return qq/
    /; +} + +#### Method: start_multipart_form +sub start_multipart_form { + my($self,@p) = self_or_default(@_); + if (defined($p[0]) && substr($p[0],0,1) eq '-') { + return $self->start_form(-enctype=>&MULTIPART,@p); + } else { + my($method,$action,@other) = + rearrange([METHOD,ACTION],@p); + return $self->start_form($method,$action,&MULTIPART,@other); + } +} + +#### Method: end_form +# End a form +# Note: This repeated below under the older name. +sub end_form { + my($self,@p) = self_or_default(@_); + if ( $NOSTICKY ) { + return wantarray ? ("
    ") : "\n"; + } else { + if (my @fields = $self->get_fields) { + return wantarray ? ("
    ",@fields,"
    ","") + : "
    ".(join '',@fields)."
    \n"; + } else { + return ""; + } + } +} + +#### Method: end_multipart_form +# end a multipart form +sub end_multipart_form { + &end_form; +} + +sub _textfield { + my($self,$tag,@p) = self_or_default(@_); + my($name,$default,$size,$maxlength,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p); + + my $current = $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $current = defined($current) ? $self->_maybe_escapeHTML($current,1) : ''; + $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; + my($s) = defined($size) ? qq/ size="$size"/ : ''; + my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : ''; + my($other) = @other ? " @other" : ''; + # this entered at cristy's request to fix problems with file upload fields + # and WebTV -- not sure it won't break stuff + my($value) = $current ne '' ? qq(value="$current") : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); +} + +#### Method: textfield +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a field +# +sub textfield { + my($self,@p) = self_or_default(@_); + $self->_textfield('text',@p); +} + +#### Method: filefield +# Parameters: +# $name -> Name of the file upload field +# $size -> Optional width of field in characaters. +# $maxlength -> Optional maximum number of characters. +# Returns: +# A string containing a field +# +sub filefield { + my($self,@p) = self_or_default(@_); + $self->_textfield('file',@p); +} + +#### Method: password +# Create a "secret password" entry field +# Parameters: +# $name -> Name of the field +# $default -> Optional default value of the field if not +# already defined. +# $size -> Optional width of field in characters. +# $maxlength -> Optional maximum characters that can be entered. +# Returns: +# A string containing a field +# +sub password_field { + my ($self,@p) = self_or_default(@_); + $self->_textfield('password',@p); +} + +#### Method: textarea +# Parameters: +# $name -> Name of the text field +# $default -> Optional default value of the field if not +# already defined. +# $rows -> Optional number of rows in text area +# $columns -> Optional number of columns in text area +# Returns: +# A string containing a tag +# +sub textarea { + my($self,@p) = self_or_default(@_); + my($name,$default,$rows,$cols,$override,$tabindex,@other) = + rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p); + + my($current)= $override ? $default : + (defined($self->param($name)) ? $self->param($name) : $default); + + $name = defined($name) ? $self->_maybe_escapeHTML($name) : ''; + $current = defined($current) ? $self->_maybe_escapeHTML($current) : ''; + my($r) = $rows ? qq/ rows="$rows"/ : ''; + my($c) = $cols ? qq/ cols="$cols"/ : ''; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return qq{}; +} + +#### Method: button +# Create a javascript button. +# Parameters: +# $name -> (optional) Name for the button. (-name) +# $value -> (optional) Value of the button when selected (and visible name) (-value) +# $onclick -> (optional) Text of the JavaScript to run when the button is +# clicked. +# Returns: +# A string containing a tag +#### +sub button { + my($self,@p) = self_or_default(@_); + + my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL], + [ONCLICK,SCRIPT],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + $script=$self->_maybe_escapeHTML($script); + + $script ||= ''; + + my($name) = ''; + $name = qq/ name="$label"/ if $label; + $value = $value || $label; + my($val) = ''; + $val = qq/ value="$value"/ if $value; + $script = qq/ onclick="$script"/ if $script; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); +} + +#### Method: submit +# Create a "submit query" button. +# Parameters: +# $name -> (optional) Name for the button. +# $value -> (optional) Value of the button when selected (also doubles as label). +# $label -> (optional) Label printed on the button(also doubles as the value). +# Returns: +# A string containing a tag +#### +sub submit { + my($self,@p) = self_or_default(@_); + + my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + + my $name = $NOSTICKY ? '' : 'name=".submit" '; + $name = qq/name="$label" / if defined($label); + $value = defined($value) ? $value : $label; + my $val = ''; + $val = qq/value="$value" / if defined($value); + $tabindex = $self->element_tab($tabindex); + my($other) = @other ? "@other " : ''; + return $XHTML ? qq() + : qq(); +} + +#### Method: reset +# Create a "reset" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a tag +#### +sub reset { + my($self,@p) = self_or_default(@_); + my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p); + $label=$self->_maybe_escapeHTML($label); + $value=$self->_maybe_escapeHTML($value,1); + my ($name) = ' name=".reset"'; + $name = qq/ name="$label"/ if defined($label); + $value = defined($value) ? $value : $label; + my($val) = ''; + $val = qq/ value="$value"/ if defined($value); + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq(); +} + +#### Method: defaults +# Create a "defaults" button. +# Parameters: +# $name -> (optional) Name for the button. +# Returns: +# A string containing a tag +# +# Note: this button has a special meaning to the initialization script, +# and tells it to ERASE the current query string so that your defaults +# are used again! +#### +sub defaults { + my($self,@p) = self_or_default(@_); + + my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p); + + $label=$self->_maybe_escapeHTML($label,1); + $label = $label || "Defaults"; + my($value) = qq/ value="$label"/; + my($other) = @other ? " @other" : ''; + $tabindex = $self->element_tab($tabindex); + return $XHTML ? qq() + : qq//; +} + +#### Method: comment +# Create an HTML +# Parameters: a string +sub comment { + my($self,@p) = self_or_CGI(@_); + return ""; +} + +#### Method: checkbox +# Create a checkbox that is not logically linked to any others. +# The field value is "on" when the button is checked. +# Parameters: +# $name -> Name of the checkbox +# $checked -> (optional) turned on by default if true +# $value -> (optional) value of the checkbox, 'on' by default +# $label -> (optional) a user-readable label printed next to the box. +# Otherwise the checkbox name is used. +# Returns: +# A string containing a field +#### +sub checkbox { + my($self,@p) = self_or_default(@_); + + my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) = + rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES, + [OVERRIDE,FORCE],TABINDEX],@p); + + $value = defined $value ? $value : 'on'; + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined $self->param($name))) { + $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : ''; + } else { + $checked = $self->_checked($checked); + } + my($the_label) = defined $label ? $label : $name; + $name = $self->_maybe_escapeHTML($name); + $value = $self->_maybe_escapeHTML($value,1); + $the_label = $self->_maybe_escapeHTML($the_label); + my($other) = @other ? "@other " : ''; + $tabindex = $self->element_tab($tabindex); + $self->register_parameter($name); + return $XHTML ? CGI::label($labelattributes, + qq{$the_label}) + : qq{$the_label}; +} + +# Escape HTML +sub escapeHTML { + require HTML::Entities; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + my $encode_entities = $ENCODE_ENTITIES; + $encode_entities .= "\012\015" if ( $encode_entities && $newlinestoo ); + return HTML::Entities::encode_entities($toencode,$encode_entities); +} + +# unescape HTML -- used internally +sub unescapeHTML { + require HTML::Entities; + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$string) = CGI::self_or_default(@_); + return undef unless defined($string); + return HTML::Entities::decode_entities($string); +} + +# Internal procedure - don't use +sub _tableize { + my($rows,$columns,$rowheaders,$colheaders,@elements) = @_; + my @rowheaders = $rowheaders ? @$rowheaders : (); + my @colheaders = $colheaders ? @$colheaders : (); + my($result); + + if (defined($columns)) { + $rows = int(0.99 + @elements/$columns) unless defined($rows); + } + if (defined($rows)) { + $columns = int(0.99 + @elements/$rows) unless defined($columns); + } + + # rearrange into a pretty table + $result = ""; + my($row,$column); + unshift(@colheaders,'') if @colheaders && @rowheaders; + $result .= "" if @colheaders; + for (@colheaders) { + $result .= ""; + } + for ($row=0;$row<$rows;$row++) { + $result .= ""; + $result .= "" if @rowheaders; + for ($column=0;$column<$columns;$column++) { + $result .= "" + if defined($elements[$column*$rows + $row]); + } + $result .= ""; + } + $result .= "
    $_
    $rowheaders[$row]" . $elements[$column*$rows + $row] . "
    "; + return $result; +} + +#### Method: radio_group +# Create a list of logically-linked radio buttons. +# Parameters: +# $name -> Common name for all the buttons. +# $values -> A pointer to a regular array containing the +# values for each button in the group. +# $default -> (optional) Value of the button to turn on by default. Pass '-' +# to turn _nothing_ on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of fields +#### +sub radio_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('radio',@p); +} + +#### Method: checkbox_group +# Create a list of logically-linked checkboxes. +# Parameters: +# $name -> Common name for all the check boxes +# $values -> A pointer to a regular array containing the +# values for each checkbox in the group. +# $defaults -> (optional) +# 1. If a pointer to a regular array of checkbox values, +# then this will be used to decide which +# checkboxes to turn on by default. +# 2. If a scalar, will be assumed to hold the +# value of a single checkbox in the group to turn on. +# $linebreak -> (optional) Set to true to place linebreaks +# between the buttons. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# An ARRAY containing a series of fields +#### + +sub checkbox_group { + my($self,@p) = self_or_default(@_); + $self->_box_group('checkbox',@p); +} + +sub _box_group { + my $self = shift; + my $box_type = shift; + + my($name,$values,$defaults,$linebreak,$labels,$labelattributes, + $attributes,$rows,$columns,$rowheaders,$colheaders, + $override,$nolabels,$tabindex,$disabled,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES, + ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER], + [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED + ],@_); + + + my($result,$checked,@elements,@values); + + @values = $self->_set_values_and_labels($values,\$labels,$name); + my %checked = $self->previous_or_default($name,$defaults,$override); + + # If no check array is specified, check the first by default + $checked{$values[0]}++ if $box_type eq 'radio' && !%checked; + + $name=$self->_maybe_escapeHTML($name); + + my %tabs = (); + if ($TABINDEX && $tabindex) { + if (!ref $tabindex) { + $self->element_tab($tabindex); + } elsif (ref $tabindex eq 'ARRAY') { + %tabs = map {$_=>$self->element_tab} @$tabindex; + } elsif (ref $tabindex eq 'HASH') { + %tabs = %$tabindex; + } + } + %tabs = map {$_=>$self->element_tab} @values unless %tabs; + my $other = @other ? "@other " : ''; + my $radio_checked; + + # for disabling groups of radio/checkbox buttons + my %disabled; + for (@{$disabled}) { + $disabled{$_}=1; + } + + for (@values) { + my $disable=""; + if ($disabled{$_}) { + $disable="disabled='1'"; + } + + my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++) + : $checked{$_}); + my($break); + if ($linebreak) { + $break = $XHTML ? "
    " : "
    "; + } + else { + $break = ''; + } + my($label)=''; + unless (defined($nolabels) && $nolabels) { + $label = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label = $self->_maybe_escapeHTML($label,1); + $label = "$label" if $disabled{$_}; + } + my $attribs = $self->_set_attributes($_, $attributes); + my $tab = $tabs{$_}; + $_=$self->_maybe_escapeHTML($_); + + if ($XHTML) { + push @elements, + CGI::label($labelattributes, + qq($label)).${break}; + } else { + push(@elements,qq/${label}${break}/); + } + } + $self->register_parameter($name); + return wantarray ? @elements : "@elements" + unless defined($columns) || defined($rows); + return _tableize($rows,$columns,$rowheaders,$colheaders,@elements); +} + +#### Method: popup_menu +# Create a popup menu. +# Parameters: +# $name -> Name for all the menu +# $values -> A pointer to a regular array containing the +# text of each menu item. +# $default -> (optional) Default item to display +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a popup menu. +#### +sub popup_menu { + my($self,@p) = self_or_default(@_); + + my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) = + rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS, + ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + my($result,%selected); + + if (!$override && defined($self->param($name))) { + $selected{$self->param($name)}++; + } elsif (defined $default) { + %selected = map {$_=>1} ref($default) eq 'ARRAY' + ? @$default + : $default; + } + $name=$self->_maybe_escapeHTML($name); + # RT #30057 - ignore -multiple, if you need this + # then use scrolling_list + @other = grep { $_ !~ /^multiple=/i } @other; + my($other) = @other ? " @other" : ''; + + my(@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + $tabindex = $self->element_tab($tabindex); + $name = q{} if ! defined $name; + $result = qq/"; + return $result; +} + +#### Method: optgroup +# Create a optgroup. +# Parameters: +# $name -> Label for the group +# $values -> A pointer to a regular array containing the +# values for each option line in the group. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each item +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# $labeled -> (optional) +# A true value indicates the value should be used as the label attribute +# in the option elements. +# The label attribute specifies the option label presented to the user. +# This defaults to the content of the \n/; + for (@values) { + if (/_set_attributes($_, $attributes); + my($label) = $_; + $label = $labels->{$_} if defined($labels) && defined($labels->{$_}); + $label=$self->_maybe_escapeHTML($label); + my($value)=$self->_maybe_escapeHTML($_,1); + $result .= $labeled ? $novals ? "$label\n" + : "$label\n" + : $novals ? "$label\n" + : "$label\n"; + } + } + $result .= ""; + return $result; +} + +#### Method: scrolling_list +# Create a scrolling list. +# Parameters: +# $name -> name for the list +# $values -> A pointer to a regular array containing the +# values for each option line in the list. +# $defaults -> (optional) +# 1. If a pointer to a regular array of options, +# then this will be used to decide which +# lines to turn on by default. +# 2. Otherwise holds the value of the single line to turn on. +# $size -> (optional) Size of the list. +# $multiple -> (optional) If set, allow multiple selections. +# $labels -> (optional) +# A pointer to a hash of labels to print next to each checkbox +# in the form $label{'value'}="Long explanatory label". +# Otherwise the provided values are used as the labels. +# Returns: +# A string containing the definition of a scrolling list. +#### +sub scrolling_list { + my($self,@p) = self_or_default(@_); + my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other) + = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT], + SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p); + + my($result,@values); + @values = $self->_set_values_and_labels($values,\$labels,$name); + + $size = $size || scalar(@values); + + my(%selected) = $self->previous_or_default($name,$defaults,$override); + + my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : ''; + my($has_size) = $size ? qq/ size="$size"/: ''; + my($other) = @other ? " @other" : ''; + + $name=$self->_maybe_escapeHTML($name); + $tabindex = $self->element_tab($tabindex); + $result = qq/"; + $self->register_parameter($name); + return $result; +} + +#### Method: hidden +# Parameters: +# $name -> Name of the hidden field +# @default -> (optional) Initial values of field (may be an array) +# or +# $default->[initial values of field] +# Returns: +# A string containing a +#### +sub hidden { + my($self,@p) = self_or_default(@_); + + # this is the one place where we departed from our standard + # calling scheme, so we have to special-case (darn) + my(@result,@value); + my($name,$default,$override,@other) = + rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p); + + my $do_override = 0; + if ( ref($p[0]) || substr($p[0],0,1) eq '-') { + @value = ref($default) ? @{$default} : $default; + $do_override = $override; + } else { + for ($default,$override,@other) { + push(@value,$_) if defined($_); + } + undef @other; + } + + # use previous values if override is not set + my @prev = $self->param($name); + @value = @prev if !$do_override && @prev; + + $name=$self->_maybe_escapeHTML($name); + for (@value) { + $_ = defined($_) ? $self->_maybe_escapeHTML($_,1) : ''; + push @result,$XHTML ? qq() + : qq(); + } + return wantarray ? @result : join('',@result); +} + +#### Method: image_button +# Parameters: +# $name -> Name of the button +# $src -> URL of the image source +# $align -> Alignment style (TOP, BOTTOM or MIDDLE) +# Returns: +# A string containing a +#### +sub image_button { + my($self,@p) = self_or_default(@_); + + my($name,$src,$alignment,@other) = + rearrange([NAME,SRC,ALIGN],@p); + + my($align) = $alignment ? " align=\L\"$alignment\"" : ''; + my($other) = @other ? " @other" : ''; + $name=$self->_maybe_escapeHTML($name); + return $XHTML ? qq() + : qq//; +} + +#### Method: self_url +# Returns a URL containing the current script and all its +# param/value pairs arranged as a query. You can use this +# to create a link that, when selected, will reinvoke the +# script with all its state information preserved. +#### +sub self_url { + my($self,@p) = self_or_default(@_); + return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p); +} + +# This is provided as a synonym to self_url() for people unfortunate +# enough to have incorporated it into their programs already! +sub state { + &self_url; +} + +#### Method: url +# Like self_url, but doesn't return the query string part of +# the URL. +#### +sub url { + my($self,@p) = self_or_default(@_); + my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) = + rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p); + my $url = ''; + $full++ if $base || !($relative || $absolute); + $rewrite++ unless defined $rewrite; + + my $path = $self->path_info; + my $script_name = $self->script_name; + my $request_uri = $self->request_uri || ''; + my $query_str = $query ? $self->query_string : ''; + + $request_uri =~ s/\?.*$//s; # remove query string + $request_uri = unescape($request_uri); + + my $uri = $rewrite && $request_uri ? $request_uri : $script_name; + $uri =~ s/\?.*$//s; # remove query string + + if ( defined( $ENV{PATH_INFO} ) ) { + # IIS sometimes sets PATH_INFO to the same value as SCRIPT_NAME so only sub it out + # if SCRIPT_NAME isn't defined or isn't the same value as PATH_INFO + $uri =~ s/\Q$ENV{PATH_INFO}\E$// + if ( ! defined( $ENV{SCRIPT_NAME} ) or $ENV{PATH_INFO} ne $ENV{SCRIPT_NAME} ); + + # if we're not IIS then keep to spec, the relevant info is here: + # https://tools.ietf.org/html/rfc3875#section-4.1.13, namely + # "No PATH_INFO segment (see section 4.1.5) is included in the + # SCRIPT_NAME value." (see GH #126, GH #152, GH #176) + if ( ! $IIS ) { + $uri =~ s/\Q$ENV{PATH_INFO}\E$//; + } + } + + if ($full) { + my $protocol = $self->protocol(); + $url = "$protocol://"; + my $vh = http('x_forwarded_host') || http('host') || ''; + $vh =~ s/^.*,\s*//; # x_forwarded_host may be a comma-separated list (e.g. when the request has + # passed through multiple reverse proxies. Take the last one. + $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it. + + $url .= $vh || server_name(); + + my $port = $self->virtual_port; + + # add the port to the url unless it's the protocol's default port + $url .= ':' . $port unless (lc($protocol) eq 'http' && $port == 80) + or (lc($protocol) eq 'https' && $port == 443); + + return $url if $base; + + $url .= $uri; + } elsif ($relative) { + ($url) = $uri =~ m!([^/]+)$!; + } elsif ($absolute) { + $url = $uri; + } + + $url .= $path if $path_info and defined $path; + $url .= "?$query_str" if $query and $query_str ne ''; + $url ||= ''; + $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg; + return $url; +} + +#### Method: cookie +# Set or read a cookie from the specified name. +# Cookie can then be passed to header(). +# Usual rules apply to the stickiness of -value. +# Parameters: +# -name -> name for this cookie (optional) +# -value -> value of this cookie (scalar, array or hash) +# -path -> paths for which this cookie is valid (optional) +# -domain -> internet domain in which this cookie is valid (optional) +# -secure -> if true, cookie only passed through secure channel (optional) +# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional) +#### +sub cookie { + my($self,@p) = self_or_default(@_); + my($name,$value,$path,$domain,$secure,$expires,$httponly) = + rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p); + + require CGI::Cookie; + + # if no value is supplied, then we retrieve the + # value of the cookie, if any. For efficiency, we cache the parsed + # cookies in our state variables. + unless ( defined($value) ) { + $self->{'.cookies'} = CGI::Cookie->fetch; + + # If no name is supplied, then retrieve the names of all our cookies. + return () unless $self->{'.cookies'}; + return keys %{$self->{'.cookies'}} unless $name; + return () unless $self->{'.cookies'}->{$name}; + return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne ''; + } + + # If we get here, we're creating a new cookie + return undef unless defined($name) && $name ne ''; # this is an error + + my @param; + push(@param,'-name'=>$name); + push(@param,'-value'=>$value); + push(@param,'-domain'=>$domain) if $domain; + push(@param,'-path'=>$path) if $path; + push(@param,'-expires'=>$expires) if $expires; + push(@param,'-secure'=>$secure) if $secure; + push(@param,'-httponly'=>$httponly) if $httponly; + + return CGI::Cookie->new(@param); +} + +sub parse_keywordlist { + my($self,$tosplit) = @_; + $tosplit = unescape($tosplit); # unescape the keywords + $tosplit=~tr/+/ /; # pluses to spaces + my(@keywords) = split(/\s+/,$tosplit); + return @keywords; +} + +sub param_fetch { + my($self,@p) = self_or_default(@_); + my($name) = rearrange([NAME],@p); + return [] unless defined $name; + + unless (exists($self->{param}{$name})) { + $self->add_parameter($name); + $self->{param}{$name} = []; + } + + return $self->{param}{$name}; +} + +############################################### +# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT +############################################### + +#### Method: path_info +# Return the extra virtual path information provided +# after the URL (if any) +#### +sub path_info { + my ($self,$info) = self_or_default(@_); + if (defined($info)) { + $info = "/$info" if $info ne '' && substr($info,0,1) ne '/'; + $self->{'.path_info'} = $info; + } elsif (! defined($self->{'.path_info'}) ) { + my (undef,$path_info) = $self->_name_and_path_from_env; + $self->{'.path_info'} = $path_info || ''; + } + return $self->{'.path_info'}; +} + +# This function returns a potentially modified version of SCRIPT_NAME +# and PATH_INFO. Some HTTP servers do sanitise the paths in those +# variables. It is the case of at least Apache 2. If for instance the +# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set: +# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y +# SCRIPT_NAME=/path/to/env.cgi +# PATH_INFO=/x/y/x +# +# This is all fine except that some bogus CGI scripts expect +# PATH_INFO=/http://foo when the user requests +# http://xxx/script.cgi/http://foo +# +# Old versions of this module used to accomodate with those scripts, so +# this is why we do this here to keep those scripts backward compatible. +# Basically, we accomodate with those scripts but within limits, that is +# we only try to preserve the number of / that were provided by the user +# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number +# of consecutive /. +# +# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a +# script_name of /x//y/script.cgi and a path_info of /a//b, but in: +# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions +# possibly sanitised by the HTTP server, so in the case of Apache 2: +# script_name == /foo/x/z/script.cgi and path_info == /b/c. +# +# Future versions of this module may no longer do that, so one should +# avoid relying on the browser, proxy, server, and CGI.pm preserving the +# number of consecutive slashes as no guarantee can be made there. +sub _name_and_path_from_env { + my $self = shift; + my $script_name = $ENV{SCRIPT_NAME} || ''; + my $path_info = $ENV{PATH_INFO} || ''; + my $uri = $self->request_uri || ''; + + $uri =~ s/\?.*//s; + $uri = unescape($uri); + + if ( $IIS ) { + # IIS doesn't set $ENV{PATH_INFO} correctly. It sets it to + # $ENV{SCRIPT_NAME}path_info + # IIS also doesn't set $ENV{REQUEST_URI} so we don't want to do + # the test below, hence this comes first + $path_info =~ s/^\Q$script_name\E(.*)/$1/; + } elsif ($uri ne "$script_name$path_info") { + my $script_name_pattern = quotemeta($script_name); + my $path_info_pattern = quotemeta($path_info); + $script_name_pattern =~ s{(?:\\/)+}{/+}g; + $path_info_pattern =~ s{(?:\\/)+}{/+}g; + + if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) { + # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the + # numer of consecutive slashes, so we can extract the info from + # REQUEST_URI: + ($script_name, $path_info) = ($1, $2); + } + } + return ($script_name,$path_info); +} + +#### Method: request_method +# Returns 'POST', 'GET', 'PUT' or 'HEAD' +#### +sub request_method { + return (defined $ENV{'REQUEST_METHOD'}) ? $ENV{'REQUEST_METHOD'} : undef; +} + +#### Method: content_type +# Returns the content_type string +#### +sub content_type { + return (defined $ENV{'CONTENT_TYPE'}) ? $ENV{'CONTENT_TYPE'} : undef; +} + +#### Method: path_translated +# Return the physical path information provided +# by the URL (if any) +#### +sub path_translated { + return (defined $ENV{'PATH_TRANSLATED'}) ? $ENV{'PATH_TRANSLATED'} : undef; +} + +#### Method: request_uri +# Return the literal request URI +#### +sub request_uri { + return (defined $ENV{'REQUEST_URI'}) ? $ENV{'REQUEST_URI'} : undef; +} + +#### Method: query_string +# Synthesize a query string from our current +# parameters +#### +sub query_string { + my($self) = self_or_default(@_); + my($param,$value,@pairs); + for $param ($self->param) { + my($eparam) = escape($param); + for $value ($self->param($param)) { + $value = escape($value); + next unless defined $value; + push(@pairs,"$eparam=$value"); + } + } + for (keys %{$self->{'.fieldnames'}}) { + push(@pairs,".cgifields=".escape("$_")); + } + return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs); +} + +sub env_query_string { + return (defined $ENV{'QUERY_STRING'}) ? $ENV{'QUERY_STRING'} : undef; +} + +#### Method: accept +# Without parameters, returns an array of the +# MIME types the browser accepts. +# With a single parameter equal to a MIME +# type, will return undef if the browser won't +# accept it, 1 if the browser accepts it but +# doesn't give a preference, or a floating point +# value between 0.0 and 1.0 if the browser +# declares a quantitative score for it. +# This handles MIME type globs correctly. +#### +sub Accept { + my($self,$search) = self_or_CGI(@_); + my(%prefs,$type,$pref,$pat); + + my(@accept) = defined $self->http('accept') + ? split(',',$self->http('accept')) + : (); + + for (@accept) { + ($pref) = /q=(\d\.\d+|\d+)/; + ($type) = m#(\S+/[^;]+)#; + next unless $type; + $prefs{$type}=$pref || 1; + } + + return keys %prefs unless $search; + + # if a search type is provided, we may need to + # perform a pattern matching operation. + # The MIME types use a glob mechanism, which + # is easily translated into a perl pattern match + + # First return the preference for directly supported + # types: + return $prefs{$search} if $prefs{$search}; + + # Didn't get it, so try pattern matching. + for (keys %prefs) { + next unless /\*/; # not a pattern match + ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters + $pat =~ s/\*/.*/g; # turn it into a pattern + return $prefs{$_} if $search=~/$pat/; + } +} + +#### Method: user_agent +# If called with no parameters, returns the user agent. +# If called with one parameter, does a pattern match (case +# insensitive) on the user agent. +#### +sub user_agent { + my($self,$match)=self_or_CGI(@_); + my $user_agent = $self->http('user_agent'); + return $user_agent unless defined $match && $match && $user_agent; + return $user_agent =~ /$match/i; +} + +#### Method: raw_cookie +# Returns the magic cookies for the session. +# The cookies are not parsed or altered in any way, i.e. +# cookies are returned exactly as given in the HTTP +# headers. If a cookie name is given, only that cookie's +# value is returned, otherwise the entire raw cookie +# is returned. +#### +sub raw_cookie { + my($self,$key) = self_or_CGI(@_); + + require CGI::Cookie; + + if (defined($key)) { + $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch + unless $self->{'.raw_cookies'}; + + return () unless $self->{'.raw_cookies'}; + return () unless $self->{'.raw_cookies'}->{$key}; + return $self->{'.raw_cookies'}->{$key}; + } + return $self->http('cookie') || $ENV{'COOKIE'} || ''; +} + +#### Method: virtual_host +# Return the name of the virtual_host, which +# is not always the same as the server +###### +sub virtual_host { + my $vh = http('x_forwarded_host') || http('host') || server_name(); + $vh =~ s/:\d+$//; # get rid of port number + return $vh; +} + +#### Method: remote_host +# Return the name of the remote host, or its IP +# address if unavailable. If this variable isn't +# defined, it returns "localhost" for debugging +# purposes. +#### +sub remote_host { + return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'} + || 'localhost'; +} + +#### Method: remote_addr +# Return the IP addr of the remote host. +#### +sub remote_addr { + return $ENV{'REMOTE_ADDR'} || '127.0.0.1'; +} + +#### Method: script_name +# Return the partial URL to this script for +# self-referencing scripts. Also see +# self_url(), which returns a URL with all state information +# preserved. +#### +sub script_name { + my ($self,@p) = self_or_default(@_); + if (@p) { + $self->{'.script_name'} = shift @p; + } elsif (!exists $self->{'.script_name'}) { + my ($script_name,$path_info) = $self->_name_and_path_from_env(); + $self->{'.script_name'} = $script_name; + } + return $self->{'.script_name'}; +} + +#### Method: referer +# Return the HTTP_REFERER: useful for generating +# a GO BACK button. +#### +sub referer { + my($self) = self_or_CGI(@_); + return $self->http('referer'); +} + +#### Method: server_name +# Return the name of the server +#### +sub server_name { + return $ENV{'SERVER_NAME'} || 'localhost'; +} + +#### Method: server_software +# Return the name of the server software +#### +sub server_software { + return $ENV{'SERVER_SOFTWARE'} || 'cmdline'; +} + +#### Method: virtual_port +# Return the server port, taking virtual hosts into account +#### +sub virtual_port { + my($self) = self_or_default(@_); + my $vh = $self->http('x_forwarded_host') || $self->http('host'); + my $protocol = $self->protocol; + if ($vh) { + return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80); + } else { + return $self->server_port(); + } +} + +#### Method: server_port +# Return the tcp/ip port the server is running on +#### +sub server_port { + return $ENV{'SERVER_PORT'} || 80; # for debugging +} + +#### Method: server_protocol +# Return the protocol (usually HTTP/1.0) +#### +sub server_protocol { + return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging +} + +#### Method: http +# Return the value of an HTTP variable, or +# the list of variables if none provided +#### +sub http { + my ($self,$parameter) = self_or_CGI(@_); + if ( defined($parameter) ) { + $parameter =~ tr/-a-z/_A-Z/; + if ( $parameter =~ /^HTTP(?:_|$)/ ) { + return $ENV{$parameter}; + } + return $ENV{"HTTP_$parameter"}; + } + return grep { /^HTTP(?:_|$)/ } keys %ENV; +} + +#### Method: https +# Return the value of HTTPS, or +# the value of an HTTPS variable, or +# the list of variables +#### +sub https { + my ($self,$parameter) = self_or_CGI(@_); + if ( defined($parameter) ) { + $parameter =~ tr/-a-z/_A-Z/; + if ( $parameter =~ /^HTTPS(?:_|$)/ ) { + return $ENV{$parameter}; + } + return $ENV{"HTTPS_$parameter"}; + } + return wantarray + ? grep { /^HTTPS(?:_|$)/ } keys %ENV + : $ENV{'HTTPS'}; +} + +#### Method: protocol +# Return the protocol (http or https currently) +#### +sub protocol { + local($^W)=0; + my $self = shift; + return 'https' if uc($self->https()) eq 'ON'; + return 'https' if $self->server_port == 443; + my $prot = $self->server_protocol; + my($protocol,$version) = split('/',$prot); + return "\L$protocol\E"; +} + +#### Method: remote_ident +# Return the identity of the remote user +# (but only if his host is running identd) +#### +sub remote_ident { + return (defined $ENV{'REMOTE_IDENT'}) ? $ENV{'REMOTE_IDENT'} : undef; +} + +#### Method: auth_type +# Return the type of use verification/authorization in use, if any. +#### +sub auth_type { + return (defined $ENV{'AUTH_TYPE'}) ? $ENV{'AUTH_TYPE'} : undef; +} + +#### Method: remote_user +# Return the authorization name used for user +# verification. +#### +sub remote_user { + return (defined $ENV{'REMOTE_USER'}) ? $ENV{'REMOTE_USER'} : undef; +} + +#### Method: user_name +# Try to return the remote user's name by hook or by +# crook +#### +sub user_name { + my ($self) = self_or_CGI(@_); + return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'}; +} + +#### Method: nosticky +# Set or return the NOSTICKY global flag +#### +sub nosticky { + my ($self,$param) = self_or_CGI(@_); + $CGI::NOSTICKY = $param if defined($param); + return $CGI::NOSTICKY; +} + +#### Method: nph +# Set or return the NPH global flag +#### +sub nph { + my ($self,$param) = self_or_CGI(@_); + $CGI::NPH = $param if defined($param); + return $CGI::NPH; +} + +#### Method: private_tempfiles +# Set or return the private_tempfiles global flag +#### +sub private_tempfiles { + warn "private_tempfiles has been deprecated"; + return 0; +} +#### Method: close_upload_files +# Set or return the close_upload_files global flag +#### +sub close_upload_files { + my ($self,$param) = self_or_CGI(@_); + $CGI::CLOSE_UPLOAD_FILES = $param if defined($param); + return $CGI::CLOSE_UPLOAD_FILES; +} + +#### Method: default_dtd +# Set or return the default_dtd global +#### +sub default_dtd { + my ($self,$param,$param2) = self_or_CGI(@_); + if (defined $param2 && defined $param) { + $CGI::DEFAULT_DTD = [ $param, $param2 ]; + } elsif (defined $param) { + $CGI::DEFAULT_DTD = $param; + } + return $CGI::DEFAULT_DTD; +} + +# -------------- really private subroutines ----------------- +sub _maybe_escapeHTML { + # hack to work around earlier hacks + push @_,$_[0] if @_==1 && $_[0] eq 'CGI'; + my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_); + return undef unless defined($toencode); + return $toencode if ref($self) && !$self->{'escape'}; + return $self->escapeHTML($toencode, $newlinestoo); +} + +sub previous_or_default { + my($self,$name,$defaults,$override) = @_; + my(%selected); + + if (!$override && ($self->{'.fieldnames'}->{$name} || + defined($self->param($name)) ) ) { + $selected{$_}++ for $self->param($name); + } elsif (defined($defaults) && ref($defaults) && + (ref($defaults) eq 'ARRAY')) { + $selected{$_}++ for @{$defaults}; + } else { + $selected{$defaults}++ if defined($defaults); + } + + return %selected; +} + +sub register_parameter { + my($self,$param) = @_; + $self->{'.parametersToAdd'}->{$param}++; +} + +sub get_fields { + my($self) = @_; + return $self->CGI::hidden('-name'=>'.cgifields', + '-values'=>[keys %{$self->{'.parametersToAdd'}}], + '-override'=>1); +} + +sub read_from_cmdline { + my($input,@words); + my($query_string); + my($subpath); + if ($DEBUG && @ARGV) { + @words = @ARGV; + } elsif ($DEBUG > 1) { + require Text::ParseWords; + print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n"; + chomp(@lines = ); # remove newlines + $input = join(" ",@lines); + @words = &Text::ParseWords::old_shellwords($input); + } + for (@words) { + s/\\=/%3D/g; + s/\\&/%26/g; + } + + if ("@words"=~/=/) { + $query_string = join('&',@words); + } else { + $query_string = join('+',@words); + } + if ($query_string =~ /^(.*?)\?(.*)$/) + { + $query_string = $2; + $subpath = $1; + } + return { 'query_string' => $query_string, 'subpath' => $subpath }; +} + +##### +# subroutine: read_multipart +# +# Read multipart data and store it into our parameters. +# An interesting feature is that if any of the parts is a file, we +# create a temporary file and open up a filehandle on it so that the +# caller can read from it if necessary. +##### +sub read_multipart { + my($self,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + $header{'Content-Disposition'} ||= ''; # quench uninit variable warning + + my($param)= $header{'Content-Disposition'}=~/[\s;]name="([^"]*)"/; + $param .= $TAINTED; + + # See RFC 1867, 2183, 2045 + # NB: File content will be loaded into memory should + # content-disposition parsing fail. + my ($filename) = $header{'Content-Disposition'} + =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i; + + $filename ||= ''; # quench uninit variable warning + + $filename =~ s/^"([^"]*)"$/$1/; + # Test for Opera's multiple upload feature + my($multipart) = ( defined( $header{'Content-Type'} ) && + $header{'Content-Type'} =~ /multipart\/mixed/ ) ? + 1 : 0; + + # add this parameter to our list + $self->add_parameter($param); + + # If no filename specified, then just read the data and assign it + # to our parameter list. + if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) { + my($value) = $buffer->readBody; + $value .= $TAINTED; + push(@{$self->{param}{$param}},$value); + next; + } + + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + # set the filename to some recognizable value + if ( ( !defined($filename) || $filename eq '' ) && $multipart ) { + $filename = "multipart/mixed"; + } + + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $filename ); + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + # if this is an multipart/mixed attachment, save the header + # together with the body for later parsing with an external + # MIME parser module + if ( $multipart ) { + for ( keys %header ) { + print $filehandle "$_: $header{$_}${CRLF}"; + } + print $filehandle "${CRLF}"; + } + + my ($data); + local($\) = ''; + my $totalbytes = 0; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push(@{$self->{param}{$param}},$filehandle); + } + } +} + +##### +# subroutine: read_multipart_related +# +# Read multipart/related data and store it into our parameters. The +# first parameter sets the start of the data. The part identified by +# this Content-ID will not be stored as a file upload, but will be +# returned by this method. All other parts will be available as file +# uploads accessible by their Content-ID +##### +sub read_multipart_related { + my($self,$start,$boundary,$length) = @_; + my($buffer) = $self->new_MultipartBuffer($boundary,$length); + return unless $buffer; + my(%header,$body); + my $filenumber = 0; + my $returnvalue; + while (!$buffer->eof) { + %header = $buffer->readHeader; + + unless (%header) { + $self->cgi_error("400 Bad request (malformed multipart POST)"); + return; + } + + my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/; + $param .= $TAINTED; + + # If this is the start part, then just read the data and assign it + # to our return variable. + if ( $param eq $start ) { + $returnvalue = $buffer->readBody; + $returnvalue .= $TAINTED; + next; + } + + # add this parameter to our list + $self->add_parameter($param); + + UPLOADS: { + # If we get here, then we are dealing with a potentially large + # uploaded form. Save the data to a temporary file, then open + # the file for reading. + + # skip the file if uploads disabled + if ($DISABLE_UPLOADS) { + while (defined($data = $buffer->read)) { } + last UPLOADS; + } + + my $tmp_dir = $CGI::OS eq 'WINDOWS' + ? ( $ENV{TEMP} || $ENV{TMP} || ( $ENV{WINDIR} ? ( $ENV{WINDIR} . $SL . 'TEMP' ) : undef ) ) + : undef; # File::Temp defaults to TMPDIR + + require CGI::File::Temp; + my $filehandle = CGI::File::Temp->new( + UNLINK => $UNLINK_TMP_FILES, + DIR => $tmp_dir, + ); + $filehandle->_mp_filename( $filehandle->filename ); + + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode + && defined fileno($filehandle); + + my ($data); + local($\) = ''; + my $totalbytes; + while (defined($data = $buffer->read)) { + if (defined $self->{'.upload_hook'}) + { + $totalbytes += length($data); + &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'}); + } + print $filehandle $data if ($self->{'use_tempfile'}); + } + + # back up to beginning of file + seek($filehandle,0,0); + + ## Close the filehandle if requested this allows a multipart MIME + ## upload to contain many files, and we won't die due to too many + ## open file handles. The user can access the files using the hash + ## below. + close $filehandle if $CLOSE_UPLOAD_FILES; + $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode; + + # Save some information about the uploaded file where we can get + # at it later. + # Use the typeglob + filename as the key, as this is guaranteed to be + # unique for each filehandle. Don't use the file descriptor as + # this will be re-used for each filehandle if the + # close_upload_files feature is used. + $self->{'.tmpfiles'}->{$$filehandle . $filehandle} = { + hndl => $filehandle, + name => $filehandle->filename, + info => {%header}, + }; + push(@{$self->{param}{$param}},$filehandle); + } + } + return $returnvalue; +} + +sub upload { + my($self,$param_name) = self_or_default(@_); + my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name); + return unless @param; + return wantarray ? @param : $param[0]; +} + +sub tmpFileName { + my($self,$filename) = self_or_default(@_); + + # preferred calling convention: $filename came directly from param or upload + if (ref $filename) { + return $self->{'.tmpfiles'}->{$$filename . $filename}->{name} || ''; + } + + # backwards compatible with older versions: $filename is merely equal to + # one of our filenames when compared as strings + foreach my $param_name ($self->param) { + foreach my $filehandle ($self->multi_param($param_name)) { + if ($filehandle eq $filename) { + return $self->{'.tmpfiles'}->{$$filehandle . $filehandle}->{name} || ''; + } + } + } + + return ''; +} + +sub uploadInfo { + my($self,$filename) = self_or_default(@_); + return if ! defined $$filename; + return $self->{'.tmpfiles'}->{$$filename . $filename}->{info}; +} + +# internal routine, don't use +sub _set_values_and_labels { + my $self = shift; + my ($v,$l,$n) = @_; + $$l = $v if ref($v) eq 'HASH' && !ref($$l); + return $self->param($n) if !defined($v); + return $v if !ref($v); + return ref($v) eq 'HASH' ? keys %$v : @$v; +} + +# internal routine, don't use +sub _set_attributes { + my $self = shift; + my($element, $attributes) = @_; + return '' unless defined($attributes->{$element}); + $attribs = ' '; + for my $attrib (keys %{$attributes->{$element}}) { + (my $clean_attrib = $attrib) =~ s/^-//; + $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" "; + } + $attribs =~ s/ $//; + return $attribs; +} + +######################################################### +# Globals and stubs for other packages that we use. +######################################################### + +######################## CGI::MultipartBuffer #################### + +package CGI::MultipartBuffer; + +$_DEBUG = 0; + +# how many bytes to read at a time. We use +# a 4K buffer by default. +$MultipartBuffer::INITIAL_FILLUNIT ||= 1024 * 4; +$MultipartBuffer::TIMEOUT ||= 240*60; # 4 hour timeout for big files +$MultipartBuffer::SPIN_LOOP_MAX ||= 2000; # bug fix for some Netscape servers +$MultipartBuffer::CRLF ||= $CGI::CRLF; + +$INITIAL_FILLUNIT = $MultipartBuffer::INITIAL_FILLUNIT; +$TIMEOUT = $MultipartBuffer::TIMEOUT; +$SPIN_LOOP_MAX = $MultipartBuffer::SPIN_LOOP_MAX; +$CRLF = $MultipartBuffer::CRLF; + +sub new { + my($package,$interface,$boundary,$length) = @_; + $FILLUNIT = $INITIAL_FILLUNIT; + $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always + + # If the user types garbage into the file upload field, + # then Netscape passes NOTHING to the server (not good). + # We may hang on this read in that case. So we implement + # a read timeout. If nothing is ready to read + # by then, we return. + + # Netscape seems to be a little bit unreliable + # about providing boundary strings. + my $boundary_read = 0; + if ($boundary) { + + # Under the MIME spec, the boundary consists of the + # characters "--" PLUS the Boundary string + + # BUG: IE 3.01 on the Macintosh uses just the boundary -- not + # the two extra hyphens. We do a special case here on the user-agent!!!! + $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport'); + + } else { # otherwise we find it ourselves + my($old); + ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line + $boundary = ; # BUG: This won't work correctly under mod_perl + $length -= length($boundary); + chomp($boundary); # remove the CRLF + $/ = $old; # restore old line separator + $boundary_read++; + } + + my $self = {LENGTH=>$length, + CHUNKED=>!$length, + BOUNDARY=>$boundary, + INTERFACE=>$interface, + BUFFER=>'', + }; + + $FILLUNIT = length($boundary) + if length($boundary) > $FILLUNIT; + + my $retval = bless $self,ref $package || $package; + + # Read the preamble and the topmost (boundary) line plus the CRLF. + unless ($boundary_read) { + while ($self->read(0)) { } + } + die "Malformed multipart POST: data truncated\n" if $self->eof; + + return $retval; +} + +sub readHeader { + my($self) = @_; + my($end); + my($ok) = 0; + my($bad) = 0; + + local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC; + + do { + $self->fillBuffer($FILLUNIT); + $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0; + $ok++ if $self->{BUFFER} eq ''; + $bad++ if !$ok && $self->{LENGTH} <= 0; + # this was a bad idea + # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT; + } until $ok || $bad; + return () if $bad; + + #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines! + + my($header) = substr($self->{BUFFER},0,$end+2); + substr($self->{BUFFER},0,$end+4) = ''; + my %return; + + if ($CGI::EBCDIC) { + warn "untranslated header=$header\n" if $_DEBUG; + $header = CGI::Util::ascii2ebcdic($header); + warn "translated header=$header\n" if $_DEBUG; + } + + # See RFC 2045 Appendix A and RFC 822 sections 3.4.8 + # (Folding Long Header Fields), 3.4.3 (Comments) + # and 3.4.5 (Quoted-Strings). + + my $token = '[-\w!\#$%&\'*+.^_\`|{}~]'; + $header=~s/$CRLF\s+/ /og; # merge continuation lines + + while ($header=~/($token+):\s+([^$CRLF]*)/mgox) { + my ($field_name,$field_value) = ($1,$2); + $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize + $return{$field_name}=$field_value; + } + return %return; +} + +# This reads and returns the body as a single scalar value. +sub readBody { + my($self) = @_; + my($data); + my($returnval)=''; + + #EBCDIC NOTE: want to translate returnval into EBCDIC HERE + + while (defined($data = $self->read)) { + $returnval .= $data; + } + + if ($CGI::EBCDIC) { + warn "untranslated body=$returnval\n" if $_DEBUG; + $returnval = CGI::Util::ascii2ebcdic($returnval); + warn "translated body=$returnval\n" if $_DEBUG; + } + return $returnval; +} + +# This will read $bytes or until the boundary is hit, whichever happens +# first. After the boundary is hit, we return undef. The next read will +# skip over the boundary and begin reading again; +sub read { + my($self,$bytes) = @_; + + # default number of bytes to read + $bytes = $bytes || $FILLUNIT; + + # Fill up our internal buffer in such a way that the boundary + # is never split between reads. + $self->fillBuffer($bytes); + + my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY}; + my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--'; + + # Find the boundary in the buffer (it may not be there). + my $start = index($self->{BUFFER},$boundary_start); + + warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if $_DEBUG; + + # protect against malformed multipart POST operations + die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0); + + #EBCDIC NOTE: want to translate boundary search into ASCII here. + + # If the boundary begins the data, then skip past it + # and return undef. + if ($start == 0) { + + # clear us out completely if we've hit the last boundary. + if (index($self->{BUFFER},$boundary_end)==0) { + $self->{BUFFER}=''; + $self->{LENGTH}=0; + return undef; + } + + # just remove the boundary. + substr($self->{BUFFER},0,length($boundary_start))=''; + $self->{BUFFER} =~ s/^\012\015?//; + return undef; + } + + my $bytesToReturn; + if ($start > 0) { # read up to the boundary + $bytesToReturn = $start-2 > $bytes ? $bytes : $start; + } else { # read the requested number of bytes + # leave enough bytes in the buffer to allow us to read + # the boundary. Thanks to Kevin Hendrick for finding + # this one. + $bytesToReturn = $bytes - (length($boundary_start)+1); + } + + my $returnval=substr($self->{BUFFER},0,$bytesToReturn); + substr($self->{BUFFER},0,$bytesToReturn)=''; + + # If we hit the boundary, remove the CRLF from the end. + return ($bytesToReturn==$start) + ? substr($returnval,0,-2) : $returnval; +} + +# This fills up our internal buffer in such a way that the +# boundary is never split between reads +sub fillBuffer { + my($self,$bytes) = @_; + return unless $self->{CHUNKED} || $self->{LENGTH}; + + my($boundaryLength) = length($self->{BOUNDARY}); + my($bufferLength) = length($self->{BUFFER}); + my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2; + $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead; + + # Try to read some data. We may hang here if the browser is screwed up. + my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER}, + $bytesToRead, + $bufferLength); + warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if $_DEBUG; + $self->{BUFFER} = '' unless defined $self->{BUFFER}; + + # An apparent bug in the Apache server causes the read() + # to return zero bytes repeatedly without blocking if the + # remote user aborts during a file transfer. I don't know how + # they manage this, but the workaround is to abort if we get + # more than SPIN_LOOP_MAX consecutive zero reads. + if ($bytesRead <= 0) { + die "CGI.pm: Server closed socket during multipart read (client aborted?).\n" + if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX); + } else { + $self->{ZERO_LOOP_COUNTER}=0; + } + + $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead; +} + +# Return true when we've finished reading +sub eof { + my($self) = @_; + return 1 if (length($self->{BUFFER}) == 0) + && ($self->{LENGTH} <= 0); + undef; +} + +1; + +package CGI; + +# We get a whole bunch of warnings about "possibly uninitialized variables" +# when running with the -w switch. Touch them all once to get rid of the +# warnings. This is ugly and I hate it. +if ($^W) { + $CGI::CGI = ''; + $CGI::CGI=<= 5.019, 'deprecate'; + +my $appease_cpants_kwalitee = q/ +use strict; +use warnings; +#/; + +#line 313 + +require 5.000; +use Exporter; +#use Carp; +BEGIN { + require Carp; + *CORE::GLOBAL::die = \&CGI::Carp::die; +} + +use File::Spec; + +@ISA = qw(Exporter); +@EXPORT = qw(confess croak carp); +@EXPORT_OK = qw(carpout fatalsToBrowser warningsToBrowser wrap noTimestamp set_message set_die_handler set_progname cluck ^name= die); + +$main::SIG{__WARN__}=\&CGI::Carp::warn; + +$CGI::Carp::VERSION = '4.35'; +$CGI::Carp::CUSTOM_MSG = undef; +$CGI::Carp::DIE_HANDLER = undef; +$CGI::Carp::TO_BROWSER = 1; +$CGI::Carp::NO_TIMESTAMP= 0; +$CGI::Carp::FULL_PATH = 0; + +# fancy import routine detects and handles 'errorWrap' specially. +sub import { + my $pkg = shift; + my(%routines); + my(@name); + if (@name=grep(/^name=/,@_)) + { + my($n) = (split(/=/,$name[0]))[1]; + set_progname($n); + @_=grep(!/^name=/,@_); + } + + grep($routines{$_}++,@_,@EXPORT); + $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'}; + $WARN++ if $routines{'warningsToBrowser'}; + my($oldlevel) = $Exporter::ExportLevel; + $Exporter::ExportLevel = 1; + Exporter::import($pkg,keys %routines); + $Exporter::ExportLevel = $oldlevel; + $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'}; + $CGI::Carp::NO_TIMESTAMP = 1 if $routines{'noTimestamp'}; +} + +# These are the originals +sub realwarn { CORE::warn(@_); } +sub realdie { CORE::die(@_); } + +sub id { + my $level = shift; + my($pack,$file,$line,$sub) = caller($level); + my($dev,$dirs,$id) = File::Spec->splitpath($file); + return ($file,$line,$id); +} + +sub stamp { + my $frame = 0; + my ($id,$pack,$file,$dev,$dirs); + if (defined($CGI::Carp::PROGNAME)) { + $id = $CGI::Carp::PROGNAME; + } else { + do { + $id = $file; + ($pack,$file) = caller($frame++); + } until !$file; + } + if (! $CGI::Carp::FULL_PATH) { + ($dev,$dirs,$id) = File::Spec->splitpath($id); + } + return "$id: " if $CGI::Carp::NO_TIMESTAMP; + my $time = scalar(localtime); + return "[$time] $id: "; +} + +sub set_progname { + $CGI::Carp::PROGNAME = shift; + return $CGI::Carp::PROGNAME; +} + + +sub warn { + my $message = shift; + my($file,$line,$id) = id(1); + $message .= " at $file line $line.\n" unless $message=~/\n$/; + _warn($message) if $WARN; + my $stamp = stamp; + $message=~s/^/$stamp/gm; + realwarn $message; +} + +sub _warn { + my $msg = shift; + if ($EMIT_WARNINGS) { + # We need to mangle the message a bit to make it a valid HTML + # comment. This is done by substituting similar-looking ISO + # 8859-1 characters for <, > and -. This is a hack. + $msg =~ tr/<>-/\253\273\255/; + chomp $msg; + print STDOUT "\n"; + } else { + push @WARNINGS, $msg; + } +} + + +# The mod_perl package Apache::Registry loads CGI programs by calling +# eval. These evals don't count when looking at the stack backtrace. +sub _longmess { + my $message = Carp::longmess(); + $message =~ s,eval[^\n]+(ModPerl|Apache)/(?:Registry|Dispatch)\w*\.pm.*,,s + if exists $ENV{MOD_PERL}; + return $message; +} + +sub ineval { + (exists $ENV{MOD_PERL} ? 0 : $^S) || _longmess() =~ /eval [\{\']/m +} + +sub die { + # if no argument is passed, propagate $@ like + # the real die + my ($arg,@rest) = @_ ? @_ + : $@ ? "$@\t...propagated" + : "Died" + ; + + &$DIE_HANDLER($arg,@rest) if $DIE_HANDLER; + + # the "$arg" is done on purpose! + # if called as die( $object, 'string' ), + # all is stringified, just like with + # the real 'die' + $arg = join '' => "$arg", @rest if @rest; + + my($file,$line,$id) = id(1); + + $arg .= " at $file line $line.\n" unless ref $arg or $arg=~/\n$/; + + realdie $arg if ineval(); + &fatalsToBrowser($arg) if ($WRAP and $CGI::Carp::TO_BROWSER); + + $arg=~s/^/ stamp() /gme if $arg =~ /\n$/ or not exists $ENV{MOD_PERL}; + + $arg .= "\n" unless $arg =~ /\n$/; + + realdie $arg; +} + +sub set_message { + $CGI::Carp::CUSTOM_MSG = shift; + return $CGI::Carp::CUSTOM_MSG; +} + +sub set_die_handler { + + my ($handler) = shift; + + #setting SIG{__DIE__} here is necessary to catch runtime + #errors which are not called by literally saying "die", + #such as the line "undef->explode();". however, doing this + #will interfere with fatalsToBrowser, which also sets + #SIG{__DIE__} in the import() function above (or the + #import() function above may interfere with this). for + #this reason, you should choose to either set the die + #handler here, or use fatalsToBrowser, not both. + $main::SIG{__DIE__} = $handler; + + $CGI::Carp::DIE_HANDLER = $handler; + + return $CGI::Carp::DIE_HANDLER; +} + +sub confess { CGI::Carp::die Carp::longmess @_; } +sub croak { CGI::Carp::die Carp::shortmess @_; } +sub carp { CGI::Carp::warn Carp::shortmess @_; } +sub cluck { CGI::Carp::warn Carp::longmess @_; } + +# We have to be ready to accept a filehandle as a reference +# or a string. +sub carpout { + my($in) = @_; + my($no) = fileno(to_filehandle($in)); + realdie("Invalid filehandle $in\n") unless defined $no; + + open(SAVEERR, ">&STDERR"); + open(STDERR, ">&$no") or + ( print SAVEERR "Unable to redirect >&$no: $!\n" and exit(1) ); +} + +sub warningsToBrowser { + $EMIT_WARNINGS = @_ ? shift : 1; + _warn(shift @WARNINGS) while $EMIT_WARNINGS and @WARNINGS; +} + +# headers +sub fatalsToBrowser { + my $msg = shift; + + $msg = "$msg" if ref $msg; + + $msg=~s/&/&/g; + $msg=~s/>/>/g; + $msg=~s/$ENV{SERVER_ADMIN})] : + "this site's webmaster"; + my ($outer_message) = <Software error: +
    $msg
    +

    +$outer_message +

    +END + ; + + if ($mod_perl) { + my $r; + if ($ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $mod_perl = 2; + require Apache2::RequestRec; + require Apache2::RequestIO; + require Apache2::RequestUtil; + require APR::Pool; + require ModPerl::Util; + require Apache2::Response; + $r = Apache2::RequestUtil->request; + } + else { + $r = Apache->request; + } + # If bytes have already been sent, then + # we print the message out directly. + # Otherwise we make a custom error + # handler to produce the doc for us. + if ($r->bytes_sent) { + $r->print($mess); + $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit; + } else { + # MSIE won't display a custom 500 response unless it is >512 bytes! + if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { + $mess = "\n$mess"; + } + $r->custom_response(500,$mess); + } + } else { + my $bytes_written = eval{tell STDOUT}; + if (defined $bytes_written && $bytes_written > 0) { + print STDOUT $mess; + } + else { + print STDOUT "Status: 500\n"; + print STDOUT "Content-type: text/html\n\n"; + # MSIE won't display a custom 500 response unless it is >512 bytes! + if (defined($ENV{HTTP_USER_AGENT}) && $ENV{HTTP_USER_AGENT} =~ /MSIE/) { + $mess = "\n$mess"; + } + print STDOUT $mess; + } + } + + warningsToBrowser(1); # emit warnings before dying +} + +# Cut and paste from CGI.pm so that we don't have the overhead of +# always loading the entire CGI module. +sub to_filehandle { + my $thingy = shift; + return undef unless $thingy; + return $thingy if UNIVERSAL::isa($thingy,'GLOB'); + return $thingy if UNIVERSAL::isa($thingy,'FileHandle'); + if (!ref($thingy)) { + my $caller = 1; + while (my $package = caller($caller++)) { + my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy"; + return $tmp if defined(fileno($tmp)); + } + } + return undef; +} + +1; diff --git a/apps/lib/CGI/Cookie.pm b/apps/lib/CGI/Cookie.pm new file mode 100644 index 0000000..b0c78c4 --- /dev/null +++ b/apps/lib/CGI/Cookie.pm @@ -0,0 +1,244 @@ +#line 1 "CGI/Cookie.pm" +package CGI::Cookie; + +use strict; +use warnings; + +use if $] >= 5.019, 'deprecate'; + +our $VERSION='4.35'; + +use CGI::Util qw(rearrange unescape escape); +use overload '""' => \&as_string, 'cmp' => \&compare, 'fallback' => 1; + +my $PERLEX = 0; +# Turn on special checking for ActiveState's PerlEx +$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/; + +# Turn on special checking for mod_perl +# PerlEx::DBI tries to fool DBI by setting MOD_PERL +my $MOD_PERL = 0; +if (exists $ENV{MOD_PERL} && ! $PERLEX) { + if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) { + $MOD_PERL = 2; + require Apache2::RequestUtil; + require APR::Table; + } else { + $MOD_PERL = 1; + require Apache; + } +} + +# fetch a list of cookies from the environment and +# return as a hash. the cookies are parsed as normal +# escaped URL data. +sub fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + return $class->parse($raw_cookie); +} + +# Fetch a list of cookies from the environment or the incoming headers and +# return as a hash. The cookie values are not unescaped or altered in any way. + sub raw_fetch { + my $class = shift; + my $raw_cookie = get_raw_cookie(@_) or return; + my %results; + my($key,$value); + + my @pairs = split("[;,] ?",$raw_cookie); + for my $pair ( @pairs ) { + $pair =~ s/^\s+|\s+$//g; # trim leading trailing whitespace + my ( $key, $value ) = split "=", $pair; + + $value = defined $value ? $value : ''; + $results{$key} = $value; + } + return wantarray ? %results : \%results; +} + +sub get_raw_cookie { + my $r = shift; + $r ||= eval { $MOD_PERL == 2 ? + Apache2::RequestUtil->request() : + Apache->request } if $MOD_PERL; + + return $r->headers_in->{'Cookie'} if $r; + + die "Run $r->subprocess_env; before calling fetch()" + if $MOD_PERL and !exists $ENV{REQUEST_METHOD}; + + return $ENV{HTTP_COOKIE} || $ENV{COOKIE}; +} + + +sub parse { + my ($self,$raw_cookie) = @_; + return wantarray ? () : {} unless $raw_cookie; + + my %results; + + my @pairs = split("[;,] ?",$raw_cookie); + for (@pairs) { + s/^\s+//; + s/\s+$//; + + my($key,$value) = split("=",$_,2); + + # Some foreign cookies are not in name=value format, so ignore + # them. + next if !defined($value); + my @values = (); + if ($value ne '') { + @values = map unescape($_),split(/[&;]/,$value.'&dmy'); + pop @values; + } + $key = unescape($key); + # A bug in Netscape can cause several cookies with same name to + # appear. The FIRST one in HTTP_COOKIE is the most recent version. + $results{$key} ||= $self->new(-name=>$key,-value=>\@values); + } + return wantarray ? %results : \%results; +} + +sub new { + my ( $class, @params ) = @_; + $class = ref( $class ) || $class; + # Ignore mod_perl request object--compatibility with Apache::Cookie. + shift if ref $params[0] + && eval { $params[0]->isa('Apache::Request::Req') || $params[0]->isa('Apache') }; + my ( $name, $value, $path, $domain, $secure, $expires, $max_age, $httponly, $samesite ) + = rearrange( + [ + 'NAME', [ 'VALUE', 'VALUES' ], + 'PATH', 'DOMAIN', + 'SECURE', 'EXPIRES', + 'MAX-AGE','HTTPONLY','SAMESITE' + ], + @params + ); + return undef unless defined $name and defined $value; + my $self = {}; + bless $self, $class; + $self->name( $name ); + $self->value( $value ); + $path ||= "/"; + $self->path( $path ) if defined $path; + $self->domain( $domain ) if defined $domain; + $self->secure( $secure ) if defined $secure; + $self->expires( $expires ) if defined $expires; + $self->max_age( $max_age ) if defined $max_age; + $self->httponly( $httponly ) if defined $httponly; + $self->samesite( $samesite ) if defined $samesite; + return $self; +} + +sub as_string { + my $self = shift; + return "" unless $self->name; + + no warnings; # some things may be undefined, that's OK. + + my $name = escape( $self->name ); + my $value = join "&", map { escape($_) } $self->value; + my @cookie = ( "$name=$value" ); + + push @cookie,"domain=".$self->domain if $self->domain; + push @cookie,"path=".$self->path if $self->path; + push @cookie,"expires=".$self->expires if $self->expires; + push @cookie,"max-age=".$self->max_age if $self->max_age; + push @cookie,"secure" if $self->secure; + push @cookie,"HttpOnly" if $self->httponly; + push @cookie,"SameSite=".$self->samesite if $self->samesite; + + return join "; ", @cookie; +} + +sub compare { + my ( $self, $value ) = @_; + return "$self" cmp $value; +} + +sub bake { + my ($self, $r) = @_; + + $r ||= eval { + $MOD_PERL == 2 + ? Apache2::RequestUtil->request() + : Apache->request + } if $MOD_PERL; + if ($r) { + $r->headers_out->add('Set-Cookie' => $self->as_string); + } else { + require CGI; + print CGI::header(-cookie => $self); + } + +} + +# accessors +sub name { + my ( $self, $name ) = @_; + $self->{'name'} = $name if defined $name; + return $self->{'name'}; +} + +sub value { + my ( $self, $value ) = @_; + if ( defined $value ) { + my @values + = ref $value eq 'ARRAY' ? @$value + : ref $value eq 'HASH' ? %$value + : ( $value ); + $self->{'value'} = [@values]; + } + return wantarray ? @{ $self->{'value'} } : $self->{'value'}->[0]; +} + +sub domain { + my ( $self, $domain ) = @_; + $self->{'domain'} = lc $domain if defined $domain; + return $self->{'domain'}; +} + +sub secure { + my ( $self, $secure ) = @_; + $self->{'secure'} = $secure if defined $secure; + return $self->{'secure'}; +} + +sub expires { + my ( $self, $expires ) = @_; + $self->{'expires'} = CGI::Util::expires($expires,'cookie') if defined $expires; + return $self->{'expires'}; +} + +sub max_age { + my ( $self, $max_age ) = @_; + $self->{'max-age'} = CGI::Util::expire_calc($max_age)-time() if defined $max_age; + return $self->{'max-age'}; +} + +sub path { + my ( $self, $path ) = @_; + $self->{'path'} = $path if defined $path; + return $self->{'path'}; +} + +sub httponly { # HttpOnly + my ( $self, $httponly ) = @_; + $self->{'httponly'} = $httponly if defined $httponly; + return $self->{'httponly'}; +} + +my %_legal_samesite = ( Strict => 1, Lax => 1 ); +sub samesite { # SameSite + my $self = shift; + my $samesite = ucfirst lc +shift if @_; # Normalize casing. + $self->{'samesite'} = $samesite if $samesite and $_legal_samesite{$samesite}; + return $self->{'samesite'}; +} + +1; + +#line 559 diff --git a/apps/lib/CGI/File/Temp.pm b/apps/lib/CGI/File/Temp.pm new file mode 100644 index 0000000..19b1461 --- /dev/null +++ b/apps/lib/CGI/File/Temp.pm @@ -0,0 +1,45 @@ +#line 1 "CGI/File/Temp.pm" +# this is a back compatibility wrapper around File::Temp. DO NOT +# use this package outside of CGI, i won't provide any help if +# you use it directly and your code breaks horribly. +package CGI::File::Temp; + +$CGI::File::Temp::VERSION = '4.35'; + +use parent File::Temp; +use parent Fh; + +my $appease_cpants_kwalitee = q/ +use strict; +use warnings; +#/; + +use overload + '""' => \&asString, + 'cmp' => \&compare, + 'fallback'=>1; + +# back compatibility method since we now return a File::Temp object +# as the filehandle (which isa IO::Handle) so calling ->handle on +# it will fail. FIXME: deprecate this method in v5+ +sub handle { return shift; }; + +sub compare { + my ( $self,$value ) = @_; + return "$self" cmp $value; +} + +sub _mp_filename { + my ( $self,$filename ) = @_; + ${*$self}->{ _mp_filename } = $filename + if $filename; + return ${*$self}->{_mp_filename}; +} + +sub asString { + my ( $self ) = @_; + return $self->_mp_filename; +} + +1; + diff --git a/apps/lib/CGI/Util.pm b/apps/lib/CGI/Util.pm new file mode 100644 index 0000000..35d2838 --- /dev/null +++ b/apps/lib/CGI/Util.pm @@ -0,0 +1,321 @@ +#line 1 "CGI/Util.pm" +package CGI::Util; +use base 'Exporter'; +require 5.008001; +use strict; +use if $] >= 5.019, 'deprecate'; +our @EXPORT_OK = qw(rearrange rearrange_header make_attributes unescape escape + expires ebcdic2ascii ascii2ebcdic); + +our $VERSION = '4.35'; + +our $_EBCDIC = "\t" ne "\011"; + +my $appease_cpants_kwalitee = q/ +use strict; +use warnings; +#/; + +# (ord('^') == 95) for codepage 1047 as on os390, vmesa +our @A2E = ( + 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, + 16, 17, 18, 19, 60, 61, 50, 38, 24, 25, 63, 39, 28, 29, 30, 31, + 64, 90,127,123, 91,108, 80,125, 77, 93, 92, 78,107, 96, 75, 97, + 240,241,242,243,244,245,246,247,248,249,122, 94, 76,126,110,111, + 124,193,194,195,196,197,198,199,200,201,209,210,211,212,213,214, + 215,216,217,226,227,228,229,230,231,232,233,173,224,189, 95,109, + 121,129,130,131,132,133,134,135,136,137,145,146,147,148,149,150, + 151,152,153,162,163,164,165,166,167,168,169,192, 79,208,161, 7, + 32, 33, 34, 35, 36, 37, 6, 23, 40, 41, 42, 43, 44, 9, 10, 27, + 48, 49, 26, 51, 52, 53, 54, 8, 56, 57, 58, 59, 4, 20, 62,255, + 65,170, 74,177,159,178,106,181,187,180,154,138,176,202,175,188, + 144,143,234,250,190,160,182,179,157,218,155,139,183,184,185,171, + 100,101, 98,102, 99,103,158,104,116,113,114,115,120,117,118,119, + 172,105,237,238,235,239,236,191,128,253,254,251,252,186,174, 89, + 68, 69, 66, 70, 67, 71,156, 72, 84, 81, 82, 83, 88, 85, 86, 87, + 140, 73,205,206,203,207,204,225,112,221,222,219,220,141,142,223 + ); +our @E2A = ( + 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15, + 16, 17, 18, 19,157, 10, 8,135, 24, 25,146,143, 28, 29, 30, 31, + 128,129,130,131,132,133, 23, 27,136,137,138,139,140, 5, 6, 7, + 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26, + 32,160,226,228,224,225,227,229,231,241,162, 46, 60, 40, 43,124, + 38,233,234,235,232,237,238,239,236,223, 33, 36, 42, 41, 59, 94, + 45, 47,194,196,192,193,195,197,199,209,166, 44, 37, 95, 62, 63, + 248,201,202,203,200,205,206,207,204, 96, 58, 35, 64, 39, 61, 34, + 216, 97, 98, 99,100,101,102,103,104,105,171,187,240,253,254,177, + 176,106,107,108,109,110,111,112,113,114,170,186,230,184,198,164, + 181,126,115,116,117,118,119,120,121,122,161,191,208, 91,222,174, + 172,163,165,183,169,167,182,188,189,190,221,168,175, 93,180,215, + 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,173,244,246,242,243,245, + 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,185,251,252,249,250,255, + 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213, + 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159 + ); + +if ($_EBCDIC && ord('^') == 106) { # as in the BS2000 posix-bc coded character set + $A2E[91] = 187; $A2E[92] = 188; $A2E[94] = 106; $A2E[96] = 74; + $A2E[123] = 251; $A2E[125] = 253; $A2E[126] = 255; $A2E[159] = 95; + $A2E[162] = 176; $A2E[166] = 208; $A2E[168] = 121; $A2E[172] = 186; + $A2E[175] = 161; $A2E[217] = 224; $A2E[219] = 221; $A2E[221] = 173; + $A2E[249] = 192; + + $E2A[74] = 96; $E2A[95] = 159; $E2A[106] = 94; $E2A[121] = 168; + $E2A[161] = 175; $E2A[173] = 221; $E2A[176] = 162; $E2A[186] = 172; + $E2A[187] = 91; $E2A[188] = 92; $E2A[192] = 249; $E2A[208] = 166; + $E2A[221] = 219; $E2A[224] = 217; $E2A[251] = 123; $E2A[253] = 125; + $E2A[255] = 126; + } +elsif ($_EBCDIC && ord('^') == 176) { # as in codepage 037 on os400 + $A2E[10] = 37; $A2E[91] = 186; $A2E[93] = 187; $A2E[94] = 176; + $A2E[133] = 21; $A2E[168] = 189; $A2E[172] = 95; $A2E[221] = 173; + + $E2A[21] = 133; $E2A[37] = 10; $E2A[95] = 172; $E2A[173] = 221; + $E2A[176] = 94; $E2A[186] = 91; $E2A[187] = 93; $E2A[189] = 168; +} + +# Smart rearrangement of parameters to allow named parameter +# calling. We do the rearrangement if: +# the first parameter begins with a - + +sub rearrange { + my ($order,@param) = @_; + my ($result, $leftover) = _rearrange_params( $order, @param ); + push @$result, make_attributes( $leftover, defined $CGI::Q ? $CGI::Q->{escape} : 1 ) + if keys %$leftover; + @$result; +} + +sub rearrange_header { + my ($order,@param) = @_; + + my ($result,$leftover) = _rearrange_params( $order, @param ); + push @$result, make_attributes( $leftover, 0, 1 ) if keys %$leftover; + + @$result; +} + +sub _rearrange_params { + my($order,@param) = @_; + return [] unless @param; + + if (ref($param[0]) eq 'HASH') { + @param = %{$param[0]}; + } else { + return \@param + unless (defined($param[0]) && substr($param[0],0,1) eq '-'); + } + + # map parameters into positional indices + my ($i,%pos); + $i = 0; + foreach (@$order) { + foreach (ref($_) eq 'ARRAY' ? @$_ : $_) { $pos{lc($_)} = $i; } + $i++; + } + + my %params_as_hash = ( @param ); + + my (@result,%leftover); + $#result = $#$order; # preextend + + foreach my $k ( + # sort keys alphabetically but favour certain keys before others + # specifically for the case where there could be several options + # for a param key, but one should be preferred (see GH #155) + sort { + if ( $a =~ /content/i ) { return 1 } + elsif ( $b =~ /content/i ) { return -1 } + else { $a cmp $b } + } + keys( %params_as_hash ) + ) { + my $key = lc($k); + $key =~ s/^\-//; + if (exists $pos{$key}) { + $result[$pos{$key}] = $params_as_hash{$k}; + } else { + $leftover{$key} = $params_as_hash{$k}; + } + } + + return \@result, \%leftover; +} + +sub make_attributes { + my $attr = shift; + return () unless $attr && ref($attr) && ref($attr) eq 'HASH'; + my $escape = shift || 0; + my $do_not_quote = shift; + + my $quote = $do_not_quote ? '' : '"'; + + my @attr_keys= sort keys %$attr; + my(@att); + foreach (@attr_keys) { + my($key) = $_; + $key=~s/^\-//; # get rid of initial - if present + + # old way: breaks EBCDIC! + # $key=~tr/A-Z_/a-z-/; # parameters are lower case, use dashes + + ($key="\L$key") =~ tr/_/-/; # parameters are lower case, use dashes + + my $value = $escape ? simple_escape($attr->{$_}) : $attr->{$_}; + push(@att,defined($attr->{$_}) ? qq/$key=$quote$value$quote/ : qq/$key/); + } + return sort @att; +} + +sub simple_escape { + return unless defined(my $toencode = shift); + $toencode =~ s{&}{&}gso; + $toencode =~ s{<}{<}gso; + $toencode =~ s{>}{>}gso; + $toencode =~ s{\"}{"}gso; +# Doesn't work. Can't work. forget it. +# $toencode =~ s{\x8b}{‹}gso; +# $toencode =~ s{\x9b}{›}gso; + $toencode; +} + +sub utf8_chr { + my $c = shift(@_); + my $u = chr($c); + utf8::encode($u); # drop utf8 flag + return $u; +} + +# unescape URL-encoded data +sub unescape { + shift() if @_ > 0 and (ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); + my $todecode = shift; + return undef unless defined($todecode); + $todecode =~ tr/+/ /; # pluses become spaces + if ($_EBCDIC) { + $todecode =~ s/%([0-9a-fA-F]{2})/chr $A2E[hex($1)]/ge; + } else { + # handle surrogate pairs first -- dankogai. Ref: http://unicode.org/faq/utf_bom.html#utf16-2 + $todecode =~ s{ + %u([Dd][89a-bA-B][0-9a-fA-F]{2}) # hi + %u([Dd][c-fC-F][0-9a-fA-F]{2}) # lo + }{ + utf8_chr( + 0x10000 + + (hex($1) - 0xD800) * 0x400 + + (hex($2) - 0xDC00) + ) + }gex; + $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/ + defined($1)? chr hex($1) : utf8_chr(hex($2))/ge; + } + return $todecode; +} + +# URL-encode data +# +# We cannot use the %u escapes, they were rejected by W3C, so the official +# way is %XX-escaped utf-8 encoding. +# Naturally, Unicode strings have to be converted to their utf-8 byte +# representation. +# Byte strings were traditionally used directly as a sequence of octets. +# This worked if they actually represented binary data (i.e. in CGI::Compress). +# This also worked if these byte strings were actually utf-8 encoded; e.g., +# when the source file used utf-8 without the appropriate "use utf8;". +# This fails if the byte string is actually a Latin 1 encoded string, but it +# was always so and cannot be fixed without breaking the binary data case. +# -- Stepan Kasal +# + +sub escape { + # If we being called in an OO-context, discard the first argument. + shift() if @_ > 1 and ( ref($_[0]) || (defined $_[1] && $_[0] eq $CGI::DefaultClass)); + my $toencode = shift; + return undef unless defined($toencode); + utf8::encode($toencode) if utf8::is_utf8($toencode); + if ($_EBCDIC) { + $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",$E2A[ord($1)])/eg; + } else { + $toencode=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg; + } + return $toencode; +} + +# This internal routine creates date strings suitable for use in +# cookies and HTTP headers. (They differ, unfortunately.) +# Thanks to Mark Fisher for this. +sub expires { + my($time,$format) = @_; + $format ||= 'http'; + + my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; + my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; + + # pass through preformatted dates for the sake of expire_calc() + $time = expire_calc($time); + return $time unless $time =~ /^\d+$/; + + # make HTTP/cookie date string from GMT'ed time + # (cookies use '-' as date separator, HTTP uses ' ') + my($sc) = ' '; + $sc = '-' if $format eq "cookie"; + my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($time); + $year += 1900; + return sprintf("%s, %02d$sc%s$sc%04d %02d:%02d:%02d GMT", + $WDAY[$wday],$mday,$MON[$mon],$year,$hour,$min,$sec); +} + +# This internal routine creates an expires time exactly some number of +# hours from the current time. It incorporates modifications from +# Mark Fisher. +sub expire_calc { + my($time) = @_; + my(%mult) = ('s'=>1, + 'm'=>60, + 'h'=>60*60, + 'd'=>60*60*24, + 'M'=>60*60*24*30, + 'y'=>60*60*24*365); + # format for time can be in any of the forms... + # "now" -- expire immediately + # "+180s" -- in 180 seconds + # "+2m" -- in 2 minutes + # "+12h" -- in 12 hours + # "+1d" -- in 1 day + # "+3M" -- in 3 months + # "+2y" -- in 2 years + # "-3m" -- 3 minutes ago(!) + # If you don't supply one of these forms, we assume you are + # specifying the date yourself + my($offset); + if (!$time || (lc($time) eq 'now')) { + $offset = 0; + } elsif ($time=~/^\d+/) { + return $time; + } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([smhdMy])/) { + $offset = ($mult{$2} || 1)*$1; + } else { + return $time; + } + my $cur_time = time; + return ($cur_time+$offset); +} + +sub ebcdic2ascii { + my $data = shift; + $data =~ s/(.)/chr $E2A[ord($1)]/ge; + $data; +} + +sub ascii2ebcdic { + my $data = shift; + $data =~ s/(.)/chr $A2E[ord($1)]/ge; + $data; +} + +1; + +__END__ + +#line 352 diff --git a/apps/lib/DBD/DBM.pm b/apps/lib/DBD/DBM.pm new file mode 100644 index 0000000..8e2c50b --- /dev/null +++ b/apps/lib/DBD/DBM.pm @@ -0,0 +1,625 @@ +#line 1 "DBD/DBM.pm" +####################################################################### +# +# DBD::DBM - a DBI driver for DBM files +# +# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > +# Copyright (c) 2010-2013 by Jens Rehsack & H.Merijn Brand +# +# All rights reserved. +# +# You may freely distribute and/or modify this module under the terms +# of either the GNU General Public License (GPL) or the Artistic License, +# as specified in the Perl README file. +# +# USERS - see the pod at the bottom of this file +# +# DBD AUTHORS - see the comments in the code +# +####################################################################### +require 5.008; +use strict; + +################# +package DBD::DBM; +################# +use base qw( DBD::File ); +use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed); +$VERSION = '0.08'; +$ATTRIBUTION = 'DBD::DBM by Jens Rehsack'; + +# no need to have driver() unless you need private methods +# +sub driver ($;$) +{ + my ( $class, $attr ) = @_; + return $drh if ($drh); + + # do the real work in DBD::File + # + $attr->{Attribution} = 'DBD::DBM by Jens Rehsack'; + $drh = $class->SUPER::driver($attr); + + # install private methods + # + # this requires that dbm_ (or foo_) be a registered prefix + # but you can write private methods before official registration + # by hacking the $dbd_prefix_registry in a private copy of DBI.pm + # + unless ( $methods_already_installed++ ) + { + DBD::DBM::st->install_method('dbm_schema'); + } + + return $drh; +} + +sub CLONE +{ + undef $drh; +} + +##################### +package DBD::DBM::dr; +##################### +$DBD::DBM::dr::imp_data_size = 0; +@DBD::DBM::dr::ISA = qw(DBD::File::dr); + +# you could put some :dr private methods here + +# you may need to over-ride some DBD::File::dr methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::db; +##################### +$DBD::DBM::db::imp_data_size = 0; +@DBD::DBM::db::ISA = qw(DBD::File::db); + +use Carp qw/carp/; + +sub validate_STORE_attr +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if ($^W); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_STORE_attr( $attrib, $value ); +} + +sub validate_FETCH_attr +{ + my ( $dbh, $attrib ) = @_; + + if ( $attrib eq "dbm_ext" or $attrib eq "dbm_lockfile" ) + { + ( my $newattrib = $attrib ) =~ s/^dbm_/f_/g; + carp "Attribute '$attrib' is depreciated, use '$newattrib' instead" if ($^W); + $attrib = $newattrib; + } + + return $dbh->SUPER::validate_FETCH_attr($attrib); +} + +sub set_versions +{ + my $this = $_[0]; + $this->{dbm_version} = $DBD::DBM::VERSION; + return $this->SUPER::set_versions(); +} + +sub init_valid_attributes +{ + my $dbh = shift; + + # define valid private attributes + # + # attempts to set non-valid attrs in connect() or + # with $dbh->{attr} will throw errors + # + # the attrs here *must* start with dbm_ or foo_ + # + # see the STORE methods below for how to check these attrs + # + $dbh->{dbm_valid_attrs} = { + dbm_type => 1, # the global DBM type e.g. SDBM_File + dbm_mldbm => 1, # the global MLDBM serializer + dbm_cols => 1, # the global column names + dbm_version => 1, # verbose DBD::DBM version + dbm_store_metadata => 1, # column names, etc. + dbm_berkeley_flags => 1, # for BerkeleyDB + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + dbm_tables => 1, # DBD::DBM public access for f_meta + }; + $dbh->{dbm_readonly_attrs} = { + dbm_version => 1, # verbose DBD::DBM version + dbm_valid_attrs => 1, # DBD::DBM::db valid attrs + dbm_readonly_attrs => 1, # DBD::DBM::db r/o attrs + dbm_meta => 1, # DBD::DBM public access for f_meta + }; + + $dbh->{dbm_meta} = "dbm_tables"; + + return $dbh->SUPER::init_valid_attributes(); +} + +sub init_default_attributes +{ + my ( $dbh, $phase ) = @_; + + $dbh->SUPER::init_default_attributes($phase); + $dbh->{f_lockfile} = '.lck'; + + return $dbh; +} + +sub get_dbm_versions +{ + my ( $dbh, $table ) = @_; + $table ||= ''; + + my $meta; + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + $table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); + $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) ); + + my $dver; + my $dtype = $meta->{dbm_type}; + eval { + $dver = $meta->{dbm_type}->VERSION(); + + # *) when we're still alive here, everything went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + if ( $meta->{dbm_mldbm} ) + { + $dtype .= ' + MLDBM'; + eval { + $dver = MLDBM->VERSION(); + $dtype .= " ($dver)"; # (*) + }; + eval { + my $ser_class = "MLDBM::Serializer::" . $meta->{dbm_mldbm}; + my $ser_mod = $ser_class; + $ser_mod =~ s|::|/|g; + $ser_mod .= ".pm"; + require $ser_mod; + $dver = $ser_class->VERSION(); + $dtype .= ' + ' . $ser_class; # (*) + $dver and $dtype .= " ($dver)"; # (*) + }; + } + return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype ); +} + +# you may need to over-ride some DBD::File::db methods here +# but you can probably get away with just letting it do the work +# in most cases + +##################### +package DBD::DBM::st; +##################### +$DBD::DBM::st::imp_data_size = 0; +@DBD::DBM::st::ISA = qw(DBD::File::st); + +sub FETCH +{ + my ( $sth, $attr ) = @_; + + if ( $attr eq "NULLABLE" ) + { + my @colnames = $sth->sql_get_colnames(); + + # XXX only BerkeleyDB fails having NULL values for non-MLDBM databases, + # none accept it for key - but it requires more knowledge between + # queries and tables storage to return fully correct information + $attr eq "NULLABLE" and return [ map { 0 } @colnames ]; + } + + return $sth->SUPER::FETCH($attr); +} # FETCH + +sub dbm_schema +{ + my ( $sth, $tname ) = @_; + return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname; + my $tbl_meta = $sth->{Database}->func( $tname, "f_schema", "get_sql_engine_meta" ) + or return $sth->set_err( $sth->{Database}->err(), $sth->{Database}->errstr() ); + return $tbl_meta->{$tname}->{f_schema}; +} +# you could put some :st private methods here + +# you may need to over-ride some DBD::File::st methods here +# but you can probably get away with just letting it do the work +# in most cases + +############################ +package DBD::DBM::Statement; +############################ + +@DBD::DBM::Statement::ISA = qw(DBD::File::Statement); + +######################## +package DBD::DBM::Table; +######################## +use Carp; +use Fcntl; + +@DBD::DBM::Table::ISA = qw(DBD::File::Table); + +my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; + +my %reset_on_modify = ( + dbm_type => "dbm_tietype", + dbm_mldbm => "dbm_tietype", + ); +__PACKAGE__->register_reset_on_modify( \%reset_on_modify ); + +my %compat_map = ( + ( map { $_ => "dbm_$_" } qw(type mldbm store_metadata) ), + dbm_ext => 'f_ext', + dbm_file => 'f_file', + dbm_lockfile => ' f_lockfile', + ); +__PACKAGE__->register_compat_map( \%compat_map ); + +sub bootstrap_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + $meta->{dbm_type} ||= $dbh->{dbm_type} || 'SDBM_File'; + $meta->{dbm_mldbm} ||= $dbh->{dbm_mldbm} if ( $dbh->{dbm_mldbm} ); + $meta->{dbm_berkeley_flags} ||= $dbh->{dbm_berkeley_flags}; + + defined $meta->{f_ext} + or $meta->{f_ext} = $dbh->{f_ext}; + unless ( defined( $meta->{f_ext} ) ) + { + my $ext; + if ( $meta->{dbm_type} eq 'SDBM_File' or $meta->{dbm_type} eq 'ODBM_File' ) + { + $ext = '.pag/r'; + } + elsif ( $meta->{dbm_type} eq 'NDBM_File' ) + { + # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley + # behind the scenes and so create a single .db file. + if ( $^O =~ /bsd/i or lc($^O) eq 'darwin' ) + { + $ext = '.db/r'; + } + elsif ( $^O eq 'SunOS' or $^O eq 'Solaris' or $^O eq 'AIX' ) + { + $ext = '.pag/r'; # here it's implemented like dbm - just a bit improved + } + # else wrapped GDBM + } + defined($ext) and $meta->{f_ext} = $ext; + } + + $self->SUPER::bootstrap_table_meta( $dbh, $meta, $table ); +} + +sub init_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + $meta->{f_dontopen} = 1; + + unless ( defined( $meta->{dbm_tietype} ) ) + { + my $tie_type = $meta->{dbm_type}; + $INC{"$tie_type.pm"} or require "$tie_type.pm"; + $tie_type eq 'BerkeleyDB' and $tie_type = 'BerkeleyDB::Hash'; + + if ( $meta->{dbm_mldbm} ) + { + $INC{"MLDBM.pm"} or require "MLDBM.pm"; + $meta->{dbm_usedb} = $tie_type; + $tie_type = 'MLDBM'; + } + + $meta->{dbm_tietype} = $tie_type; + } + + unless ( defined( $meta->{dbm_store_metadata} ) ) + { + my $store = $dbh->{dbm_store_metadata}; + defined($store) or $store = 1; + $meta->{dbm_store_metadata} = $store; + } + + unless ( defined( $meta->{col_names} ) ) + { + defined( $dbh->{dbm_cols} ) and $meta->{col_names} = $dbh->{dbm_cols}; + } + + $self->SUPER::init_table_meta( $dbh, $meta, $table ); +} + +sub open_data +{ + my ( $className, $meta, $attrs, $flags ) = @_; + $className->SUPER::open_data( $meta, $attrs, $flags ); + + unless ( $flags->{dropMode} ) + { + # TIEING + # + # XXX allow users to pass in a pre-created tied object + # + my @tie_args; + if ( $meta->{dbm_type} eq 'BerkeleyDB' ) + { + my $DB_CREATE = BerkeleyDB::DB_CREATE(); + my $DB_RDONLY = BerkeleyDB::DB_RDONLY(); + my %tie_flags; + if ( my $f = $meta->{dbm_berkeley_flags} ) + { + defined( $f->{DB_CREATE} ) and $DB_CREATE = delete $f->{DB_CREATE}; + defined( $f->{DB_RDONLY} ) and $DB_RDONLY = delete $f->{DB_RDONLY}; + %tie_flags = %$f; + } + my $open_mode = $flags->{lockMode} || $flags->{createMode} ? $DB_CREATE : $DB_RDONLY; + @tie_args = ( + -Filename => $meta->{f_fqbn}, + -Flags => $open_mode, + %tie_flags + ); + } + else + { + my $open_mode = O_RDONLY; + $flags->{lockMode} and $open_mode = O_RDWR; + $flags->{createMode} and $open_mode = O_RDWR | O_CREAT | O_TRUNC; + + @tie_args = ( $meta->{f_fqbn}, $open_mode, 0666 ); + } + + if ( $meta->{dbm_mldbm} ) + { + $MLDBM::UseDB = $meta->{dbm_usedb}; + $MLDBM::Serializer = $meta->{dbm_mldbm}; + } + + $meta->{hash} = {}; + my $tie_class = $meta->{dbm_tietype}; + eval { tie %{ $meta->{hash} }, $tie_class, @tie_args }; + $@ and croak "Cannot tie(\%h $tie_class @tie_args): $@"; + -f $meta->{f_fqfn} or croak( "No such file: '" . $meta->{f_fqfn} . "'" ); + } + + unless ( $flags->{createMode} ) + { + my ( $meta_data, $schema, $col_names ); + if ( $meta->{dbm_store_metadata} ) + { + $meta_data = $col_names = $meta->{hash}->{"_metadata \0"}; + if ( $meta_data and $meta_data =~ m~(.+)~is ) + { + $schema = $col_names = $1; + $schema =~ s~.*(.+).*~$1~is; + $col_names =~ s~.*(.+).*~$1~is; + } + } + $col_names ||= $meta->{col_names} || [ 'k', 'v' ]; + $col_names = [ split /,/, $col_names ] if ( ref $col_names ne 'ARRAY' ); + if ( $meta->{dbm_store_metadata} and not $meta->{hash}->{"_metadata \0"} ) + { + $schema or $schema = ''; + $meta->{hash}->{"_metadata \0"} = + "" + . "$schema" + . "" + . join( ",", @{$col_names} ) + . "" + . ""; + } + + $meta->{schema} = $schema; + $meta->{col_names} = $col_names; + } +} + +# you must define drop +# it is called from execute of a SQL DROP statement +# +sub drop ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + $self->SUPER::drop($data); + # XXX extra_files + -f $meta->{f_fqbn} . $dirfext + and $meta->{f_ext} eq '.pag/r' + and unlink( $meta->{f_fqbn} . $dirfext ); + return 1; +} + +# you must define fetch_row, it is called on all fetches; +# it MUST return undef when no rows are left to fetch; +# checking for $ary[0] is specific to hashes so you'll +# probably need some other kind of check for nothing-left. +# as Janis might say: "undef's just another word for +# nothing left to fetch" :-) +# +sub fetch_row ($$) +{ + my ( $self, $data ) = @_; + my $meta = $self->{meta}; + # fetch with %each + # + my @ary = each %{ $meta->{hash} }; + $meta->{dbm_store_metadata} + and $ary[0] + and $ary[0] eq "_metadata \0" + and @ary = each %{ $meta->{hash} }; + + my ( $key, $val ) = @ary; + unless ($key) + { + delete $self->{row}; + return; + } + my @row = ( ref($val) eq 'ARRAY' ) ? ( $key, @$val ) : ( $key, $val ); + $self->{row} = @row ? \@row : undef; + return wantarray ? @row : \@row; +} + +# you must define push_row except insert_new_row and update_specific_row is defined +# it is called on inserts and updates as primitive +# +sub insert_new_row ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + my $ncols = scalar( @{ $meta->{col_names} } ); + my $nitems = scalar( @{$row_aryref} ); + $ncols == $nitems + or croak "You tried to insert $nitems, but table is created with $ncols columns"; + + my $key = shift @$row_aryref; + my $exists; + eval { $exists = exists( $meta->{hash}->{$key} ); }; + $exists and croak "Row with PK '$key' already exists"; + + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row_aryref : $row_aryref->[0]; + + return 1; +} + +# this is where you grab the column names from a CREATE statement +# if you don't need to do that, it must be defined but can be empty +# +sub push_names ($$$) +{ + my ( $self, $data, $row_aryref ) = @_; + my $meta = $self->{meta}; + + # some sanity checks ... + my $ncols = scalar(@$row_aryref); + $ncols < 2 and croak "At least 2 columns are required for DBD::DBM tables ..."; + !$meta->{dbm_mldbm} + and $ncols > 2 + and croak "Without serializing with MLDBM only 2 columns are supported, you give $ncols"; + $meta->{col_names} = $row_aryref; + return unless $meta->{dbm_store_metadata}; + + my $stmt = $data->{sql_stmt}; + my $col_names = join( ',', @{$row_aryref} ); + my $schema = $data->{Database}->{Statement}; + $schema =~ s/^[^\(]+\((.+)\)$/$1/s; + $schema = $stmt->schema_str() if ( $stmt->can('schema_str') ); + $meta->{hash}->{"_metadata \0"} = + "" + . "$schema" + . "$col_names" + . ""; +} + +# fetch_one_row, delete_one_row, update_one_row +# are optimized for hash-style lookup without looping; +# if you don't need them, omit them, they're optional +# but, in that case you may need to define +# truncate() and seek(), see below +# +sub fetch_one_row ($$;$) +{ + my ( $self, $key_only, $key ) = @_; + my $meta = $self->{meta}; + $key_only and return $meta->{col_names}->[0]; + exists $meta->{hash}->{$key} or return; + my $val = $meta->{hash}->{$key}; + $val = ( ref($val) eq 'ARRAY' ) ? $val : [$val]; + my $row = [ $key, @$val ]; + return wantarray ? @{$row} : $row; +} + +sub delete_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + delete $meta->{hash}->{ $aryref->[0] }; +} + +sub update_one_row ($$$) +{ + my ( $self, $data, $aryref ) = @_; + my $meta = $self->{meta}; + my $key = shift @$aryref; + defined $key or return; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$key} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +sub update_specific_row ($$$$) +{ + my ( $self, $data, $aryref, $origary ) = @_; + my $meta = $self->{meta}; + my $key = shift @$origary; + my $newkey = shift @$aryref; + return unless ( defined $key ); + $key eq $newkey or delete $meta->{hash}->{$key}; + my $row = ( ref($aryref) eq 'ARRAY' ) ? $aryref : [$aryref]; + $meta->{hash}->{$newkey} = $meta->{dbm_mldbm} ? $row : $row->[0]; +} + +# you may not need to explicitly DESTROY the ::Table +# put cleanup code to run when the execute is done +# +sub DESTROY ($) +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{hash} and untie %{ $meta->{hash} }; + + $self->SUPER::DESTROY(); +} + +# truncate() and seek() must be defined to satisfy DBI::SQL::Nano +# *IF* you define the *_one_row methods above, truncate() and +# seek() can be empty or you can use them without actually +# truncating or seeking anything but if you don't define the +# *_one_row methods, you may need to define these + +# if you need to do something after a series of +# deletes or updates, you can put it in truncate() +# which is called at the end of executing +# +sub truncate ($$) +{ + # my ( $self, $data ) = @_; + return 1; +} + +# seek() is only needed if you use IO::File +# though it could be used for other non-file operations +# that you need to do before "writes" or truncate() +# +sub seek ($$$$) +{ + # my ( $self, $data, $pos, $whence ) = @_; + return 1; +} + +# Th, th, th, that's all folks! See DBD::File and DBD::CSV for other +# examples of creating pure perl DBDs. I hope this helped. +# Now it's time to go forth and create your own DBD! +# Remember to check in with dbi-dev@perl.org before you get too far. +# We may be able to make suggestions or point you to other related +# projects. + +1; +__END__ + +#line 1455 diff --git a/apps/lib/DBD/ExampleP.pm b/apps/lib/DBD/ExampleP.pm new file mode 100644 index 0000000..a5cbb04 --- /dev/null +++ b/apps/lib/DBD/ExampleP.pm @@ -0,0 +1,436 @@ +#line 1 "DBD/ExampleP.pm" +{ + package DBD::ExampleP; + + use strict; + use Symbol; + + use DBI qw(:sql_types); + + require File::Spec; + + our (@EXPORT,$VERSION,@statnames,%statnames,@stattypes,%stattypes, + @statprec,%statprec,$drh,); + + @EXPORT = qw(); # Do NOT @EXPORT anything. + $VERSION = "12.014311"; + +# $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z Jens $ +# +# Copyright (c) 1994,1997,1998 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + @statnames = qw(dev ino mode nlink + uid gid rdev size + atime mtime ctime + blksize blocks name); + @statnames{@statnames} = (0 .. @statnames-1); + + @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); + @stattypes{@statnames} = @stattypes; + @statprec = ((10) x (@statnames-1), 1024); + @statprec{@statnames} = @statprec; + die unless @statnames == @stattypes; + die unless @statprec == @stattypes; + + $drh = undef; # holds driver handle once initialised + #$gensym = "SYM000"; # used by st::execute() for filehandles + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'ExampleP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Perl stub by Tim Bunce', + }, ['example implementors private data '.__PACKAGE__]); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::ExampleP::dr; # ====== DRIVER ====== + $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my($drh, $dbname, $user, $auth)= @_; + my ($outer, $dbh) = DBI::_new_dbh($drh, { + Name => $dbname, + examplep_private_dbh_attrib => 42, # an example, for testing + }); + $dbh->{examplep_get_info} = { + 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR + 41 => '.', # SQL_CATALOG_NAME_SEPARATOR + 114 => 1, # SQL_CATALOG_LOCATION + }; + #$dbh->{Name} = $dbname; + $dbh->STORE('Active', 1); + return $outer; + } + + sub data_sources { + return ("dbi:ExampleP:dir=."); # possibly usefully meaningless + } + +} + + +{ package DBD::ExampleP::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement)= @_; + my @fields; + my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; + + if (defined $fields and defined $dir) { + @fields = ($fields eq '*') + ? keys %DBD::ExampleP::statnames + : split(/\s*,\s*/, $fields); + } + else { + return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")") + unless $statement =~ m/^\s*set\s+/; + # the SET syntax is just a hack so the ExampleP driver can + # be used to test non-select statements. + # Now we have DBI::DBM etc., ExampleP should be deprecated + } + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + examplep_private_sth_attrib => 24, # an example, for testing + }, ['example implementors private data '.__PACKAGE__]); + + my @bad = map { + defined $DBD::ExampleP::statnames{$_} ? () : $_ + } @fields; + return $dbh->set_err($DBI::stderr, "Unknown field names: @bad") + if @bad; + + $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); + + $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/; + $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0); + + if (@fields) { + $outer->STORE('NAME' => \@fields); + $outer->STORE('NULLABLE' => [ (0) x @fields ]); + $outer->STORE('SCALE' => [ (0) x @fields ]); + } + + $outer; + } + + + sub table_info { + my $dbh = shift; + my ($catalog, $schema, $table, $type) = @_; + + my @types = split(/["']*,["']/, $type || 'TABLE'); + my %types = map { $_=>$_ } @types; + + # Return a list of all subdirectories + my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + my $dir = $catalog || File::Spec->curdir(); + my @list; + if ($types{VIEW}) { # for use by test harness + push @list, [ undef, "schema", "table", 'VIEW', undef ]; + push @list, [ undef, "sch-ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ]; + push @list, [ undef, "sch ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta ble", 'VIEW', undef ]; + } + if ($types{TABLE}) { + no strict 'refs'; + opendir($dh, $dir) + or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); + while (defined(my $item = readdir($dh))) { + if ($^O eq 'VMS') { + # if on VMS then avoid warnings from catdir if you use a file + # (not a dir) as the item below + next if $item !~ /\.dir$/oi; + } + my $file = File::Spec->catdir($dir,$item); + next unless -d $file; + my($dev, $ino, $mode, $nlink, $uid) = lstat($file); + my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; + push @list, [ $dir, $pwnam, $item, 'TABLE', undef ]; + } + close($dh); + } + # We would like to simply do a DBI->connect() here. However, + # this is wrong if we are in a subclass like DBI::ProxyServer. + $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') + or return $dbh->set_err($DBI::err, + "Failed to connect to DBI::Sponge: $DBI::errstr"); + + my $attr = { + 'rows' => \@list, + 'NUM_OF_FIELDS' => 5, + 'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', + 'TABLE_TYPE', 'REMARKS'], + 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), + DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ], + 'NULLABLE' => [1, 1, 1, 1, 1] + }; + my $sdbh = $dbh->{'dbd_sponge_dbh'}; + my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) + or return $dbh->set_err($sdbh->err(), $sdbh->errstr()); + $sth; + } + + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE=> 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + + sub ping { + (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t + } + + + sub disconnect { + shift->STORE(Active => 0); + return 1; + } + + + sub get_info { + my ($dbh, $info_type) = @_; + return $dbh->{examplep_get_info}->{$info_type}; + } + + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + # else pass up to DBI to handle + return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path'; + return $dbh->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # store only known attributes else pass up to DBI to handle + if ($attrib eq 'examplep_set_err') { + # a fake attribute to enable a test case where STORE issues a warning + $dbh->set_err($value, $value); + return; + } + if ($attrib eq 'AutoCommit') { + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; + return $dbh->SUPER::STORE($attrib, $value); + } + + sub DESTROY { + my $dbh = shift; + $dbh->disconnect if $dbh->FETCH('Active'); + undef + } + + + # This is an example to demonstrate the use of driver-specific + # methods via $dbh->func(). + # Use it as follows: + # my @tables = $dbh->func($re, 'examplep_tables'); + # + # Returns all the tables that match the regular expression $re. + sub examplep_tables { + my $dbh = shift; my $re = shift; + grep { $_ =~ /$re/ } $dbh->tables(); + } + + sub parse_trace_flag { + my ($h, $name) = @_; + return 0x01000000 if $name eq 'foo'; + return 0x02000000 if $name eq 'bar'; + return 0x04000000 if $name eq 'baz'; + return 0x08000000 if $name eq 'boo'; + return 0x10000000 if $name eq 'bop'; + return $h->SUPER::parse_trace_flag($name); + } + + sub private_attribute_info { + return { example_driver_path => undef }; + } +} + + +{ package DBD::ExampleP::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; no strict 'refs'; # cause problems with filehandles + + sub bind_param { + my($sth, $param, $value, $attribs) = @_; + $sth->{'dbd_param'}->[$param-1] = $value; + return 1; + } + + + sub execute { + my($sth, @dir) = @_; + my $dir; + + if (@dir) { + $sth->bind_param($_, $dir[$_-1]) or return + foreach (1..@dir); + } + + my $dbd_param = $sth->{'dbd_param'} || []; + return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected") + unless @$dbd_param == $sth->{NUM_OF_PARAMS}; + + return 0 unless $sth->{NUM_OF_FIELDS}; # not a select + + $dir = $dbd_param->[0] || $sth->{examplep_ex_dir}; + return $sth->set_err(2, "No bind parameter supplied") + unless defined $dir; + + $sth->finish; + + # + # If the users asks for directory "long_list_4532", then we fake a + # directory with files "file4351", "file4350", ..., "file0". + # This is a special case used for testing, especially DBD::Proxy. + # + if ($dir =~ /^long_list_(\d+)$/) { + $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode + $sth->{dbd_datahandle} = undef; + } + else { + $sth->{dbd_dir} = $dir; + my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + opendir($sym, $dir) + or return $sth->set_err(2, "opendir($dir): $!"); + $sth->{dbd_datahandle} = $sym; + } + $sth->STORE(Active => 1); + return 1; + } + + + sub fetch { + my $sth = shift; + my $dir = $sth->{dbd_dir}; + my %s; + + if (ref $dir) { # special fake-data test mode + my $num = $dir->[0]--; + unless ($num > 0) { + $sth->finish(); + return; + } + my $time = time; + @s{@DBD::ExampleP::statnames} = + ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, + $time, $time, $time, 512, 2, "file$num") + } + else { # normal mode + my $dh = $sth->{dbd_datahandle} + or return $sth->set_err($DBI::stderr, "fetch without successful execute"); + my $f = readdir($dh); + unless ($f) { + $sth->finish; + return; + } + # untaint $f so that we can use this for DBI taint tests + ($f) = ($f =~ m/^(.*)$/); + my $file = File::Spec->catfile($dir, $f); + # put in all the data fields + @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); + } + + # return just what fields the query asks for + my @new = @s{ @{$sth->{NAME}} }; + + return $sth->_set_fbav(\@new); + } + *fetchrow_arrayref = \&fetch; + + + sub finish { + my $sth = shift; + closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; + $sth->{dbd_datahandle} = undef; + $sth->{dbd_dir} = undef; + $sth->SUPER::finish(); + return 1; + } + + + sub FETCH { + my ($sth, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + if ($attrib eq 'TYPE'){ + return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'PRECISION'){ + return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'ParamValues') { + my $dbd_param = $sth->{dbd_param} || []; + my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param; + return \%pv; + } + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->{$attrib} = $value + if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; + return $sth->SUPER::STORE($attrib, $value); + } + + *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag; +} + +1; +# vim: sw=4:ts=8 diff --git a/apps/lib/DBD/File.pm b/apps/lib/DBD/File.pm new file mode 100644 index 0000000..ab0419c --- /dev/null +++ b/apps/lib/DBD/File.pm @@ -0,0 +1,968 @@ +#line 1 "DBD/File.pm" +# -*- perl -*- +# +# DBD::File - A base class for implementing DBI drivers that +# act on plain files +# +# This module is currently maintained by +# +# H.Merijn Brand & Jens Rehsack +# +# The original author is Jochen Wiedmann. +# +# Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack +# Copyright (C) 2004 by Jeff Zucker +# Copyright (C) 1998 by Jochen Wiedmann +# +# All rights reserved. +# +# You may distribute this module under the terms of either the GNU +# General Public License or the Artistic License, as specified in +# the Perl README file. + +require 5.008; + +use strict; +use warnings; + +use DBI (); + +package DBD::File; + +use strict; +use warnings; + +use base qw( DBI::DBD::SqlEngine ); +use Carp; +use vars qw( @ISA $VERSION $drh ); + +$VERSION = "0.44"; + +$drh = undef; # holds driver handle(s) once initialized + +sub driver ($;$) +{ + my ($class, $attr) = @_; + + # Drivers typically use a singleton object for the $drh + # We use a hash here to have one singleton per subclass. + # (Otherwise DBD::CSV and DBD::DBM, for example, would + # share the same driver object which would cause problems.) + # An alternative would be to not cache the $drh here at all + # and require that subclasses do that. Subclasses should do + # their own caching, so caching here just provides extra safety. + $drh->{$class} and return $drh->{$class}; + + $attr ||= {}; + { no strict "refs"; + unless ($attr->{Attribution}) { + $class eq "DBD::File" and + $attr->{Attribution} = "$class by Jeff Zucker"; + $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} || + "oops the author of $class forgot to define this"; + } + $attr->{Version} ||= ${$class . "::VERSION"}; + $attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://; + } + + $drh->{$class} = $class->SUPER::driver ($attr); + + # XXX inject DBD::XXX::Statement unless exists + + return $drh->{$class}; + } # driver + +sub CLONE +{ + undef $drh; + } # CLONE + +# ====== DRIVER ================================================================ + +package DBD::File::dr; + +use strict; +use warnings; + +use vars qw( @ISA $imp_data_size ); + +use Carp; + +@DBD::File::dr::ISA = qw( DBI::DBD::SqlEngine::dr ); +$DBD::File::dr::imp_data_size = 0; + +sub dsn_quote +{ + my $str = shift; + ref $str and return ""; + defined $str or return ""; + $str =~ s/([;:\\])/\\$1/g; + return $str; + } # dsn_quote + +# XXX rewrite using TableConfig ... +sub default_table_source { "DBD::File::TableSource::FileSystem" } + +sub connect +{ + my ($drh, $dbname, $user, $auth, $attr) = @_; + + # We do not (yet) care about conflicting attributes here + # my $dbh = DBI->connect ("dbi:CSV:f_dir=test", undef, undef, { f_dir => "text" }); + # will test here that both test and text should exist + if (my $attr_hash = (DBI->parse_dsn ($dbname))[3]) { + if (defined $attr_hash->{f_dir} && ! -d $attr_hash->{f_dir}) { + my $msg = "No such directory '$attr_hash->{f_dir}"; + $drh->set_err (2, $msg); + $attr_hash->{RaiseError} and croak $msg; + return; + } + } + if ($attr and defined $attr->{f_dir} && ! -d $attr->{f_dir}) { + my $msg = "No such directory '$attr->{f_dir}"; + $drh->set_err (2, $msg); + $attr->{RaiseError} and croak $msg; + return; + } + + return $drh->SUPER::connect ($dbname, $user, $auth, $attr); + } # connect + +sub disconnect_all +{ + } # disconnect_all + +sub DESTROY +{ + undef; + } # DESTROY + +# ====== DATABASE ============================================================== + +package DBD::File::db; + +use strict; +use warnings; + +use vars qw( @ISA $imp_data_size ); + +use Carp; +require File::Spec; +require Cwd; +use Scalar::Util qw( refaddr ); # in CORE since 5.7.3 + +@DBD::File::db::ISA = qw( DBI::DBD::SqlEngine::db ); +$DBD::File::db::imp_data_size = 0; + +sub data_sources +{ + my ($dbh, $attr, @other) = @_; + ref ($attr) eq "HASH" or $attr = {}; + exists $attr->{f_dir} or $attr->{f_dir} = $dbh->{f_dir}; + exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search}; + return $dbh->SUPER::data_sources ($attr, @other); + } # data_source + +sub set_versions +{ + my $dbh = shift; + $dbh->{f_version} = $DBD::File::VERSION; + + return $dbh->SUPER::set_versions (); + } # set_versions + +sub init_valid_attributes +{ + my $dbh = shift; + + $dbh->{f_valid_attrs} = { + f_version => 1, # DBD::File version + f_dir => 1, # base directory + f_dir_search => 1, # extended search directories + f_ext => 1, # file extension + f_schema => 1, # schema name + f_lock => 1, # Table locking mode + f_lockfile => 1, # Table lockfile extension + f_encoding => 1, # Encoding of the file + f_valid_attrs => 1, # File valid attributes + f_readonly_attrs => 1, # File readonly attributes + }; + $dbh->{f_readonly_attrs} = { + f_version => 1, # DBD::File version + f_valid_attrs => 1, # File valid attributes + f_readonly_attrs => 1, # File readonly attributes + }; + + return $dbh->SUPER::init_valid_attributes (); + } # init_valid_attributes + +sub init_default_attributes +{ + my ($dbh, $phase) = @_; + + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->SUPER::init_default_attributes ($phase); + + # DBI::BD::SqlEngine::dr::connect will detect old-style drivers and + # don't call twice + unless (defined $phase) { + # we have an "old" driver here + $phase = defined $dbh->{sql_init_phase}; + $phase and $phase = $dbh->{sql_init_phase}; + } + + if (0 == $phase) { + # f_ext should not be initialized + # f_map is deprecated (but might return) + $dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ()); + + push @{$dbh->{sql_init_order}{90}}, "f_meta"; + + # complete derived attributes, if required + (my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix ($drv_class); + if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) { + my $attr = $dbh->{$drv_prefix . "meta"}; + defined $dbh->{f_valid_attrs}{f_meta} + and $dbh->{f_valid_attrs}{f_meta} = 1; + + $dbh->{f_meta} = $dbh->{$attr}; + } + } + + return $dbh; + } # init_default_attributes + +sub validate_FETCH_attr +{ + my ($dbh, $attrib) = @_; + + $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta"; + + return $dbh->SUPER::validate_FETCH_attr ($attrib); + } # validate_FETCH_attr + +sub validate_STORE_attr +{ + my ($dbh, $attrib, $value) = @_; + + if ($attrib eq "f_dir" && defined $value) { + -d $value or + return $dbh->set_err ($DBI::stderr, "No such directory '$value'"); + File::Spec->file_name_is_absolute ($value) or + $value = Cwd::abs_path ($value); + } + + if ($attrib eq "f_ext") { + $value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or + carp "'$value' doesn't look like a valid file extension attribute\n"; + } + + $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta"; + + return $dbh->SUPER::validate_STORE_attr ($attrib, $value); + } # validate_STORE_attr + +sub get_f_versions +{ + my ($dbh, $table) = @_; + + my $class = $dbh->{ImplementorClass}; + $class =~ s/::db$/::Table/; + my $dver; + my $dtype = "IO::File"; + eval { + $dver = IO::File->VERSION (); + + # when we're still alive here, everything went ok - no need to check for $@ + $dtype .= " ($dver)"; + }; + + my $f_encoding; + if ($table) { + my $meta; + $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1); + $meta and $meta->{f_encoding} and $f_encoding = $meta->{f_encoding}; + } # if ($table) + $f_encoding ||= $dbh->{f_encoding}; + + $f_encoding and $dtype .= " + " . $f_encoding . " encoding"; + + return sprintf "%s using %s", $dbh->{f_version}, $dtype; + } # get_f_versions + +# ====== STATEMENT ============================================================= + +package DBD::File::st; + +use strict; +use warnings; + +use vars qw( @ISA $imp_data_size ); + +@DBD::File::st::ISA = qw( DBI::DBD::SqlEngine::st ); +$DBD::File::st::imp_data_size = 0; + +my %supported_attrs = ( + TYPE => 1, + PRECISION => 1, + NULLABLE => 1, + ); + +sub FETCH +{ + my ($sth, $attr) = @_; + + if ($supported_attrs{$attr}) { + my $stmt = $sth->{sql_stmt}; + + if (exists $sth->{ImplementorClass} && + exists $sth->{sql_stmt} && + $sth->{sql_stmt}->isa ("SQL::Statement")) { + + # fill overall_defs unless we know + unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) { + my $types = $sth->{Database}{Types}; + unless ($types) { # Fetch types only once per database + if (my $t = $sth->{Database}->type_info_all ()) { + foreach my $i (1 .. $#$t) { + $types->{uc $t->[$i][0]} = $t->[$i][1]; + $types->{$t->[$i][1]} ||= uc $t->[$i][0]; + } + } + # sane defaults + for ([ 0, "" ], + [ 1, "CHAR" ], + [ 4, "INTEGER" ], + [ 12, "VARCHAR" ], + ) { + $types->{$_->[0]} ||= $_->[1]; + $types->{$_->[1]} ||= $_->[0]; + } + $sth->{Database}{Types} = $types; + } + my $all_meta = + $sth->{Database}->func ("*", "table_defs", "get_sql_engine_meta"); + foreach my $tbl (keys %$all_meta) { + my $meta = $all_meta->{$tbl}; + exists $meta->{table_defs} && ref $meta->{table_defs} or next; + foreach (keys %{$meta->{table_defs}{columns}}) { + my $field_info = $meta->{table_defs}{columns}{$_}; + if (defined $field_info->{data_type} && + $field_info->{data_type} !~ m/^[0-9]+$/) { + $field_info->{type_name} = uc $field_info->{data_type}; + $field_info->{data_type} = $types->{$field_info->{type_name}} || 0; + } + $field_info->{type_name} ||= $types->{$field_info->{data_type}} || "CHAR"; + $sth->{f_overall_defs}{$_} = $field_info; + } + } + } + + my @colnames = $sth->sql_get_colnames (); + + $attr eq "TYPE" and + return [ map { $sth->{f_overall_defs}{$_}{data_type} || 12 } + @colnames ]; + + $attr eq "TYPE_NAME" and + return [ map { $sth->{f_overall_defs}{$_}{type_name} || "VARCHAR" } + @colnames ]; + + $attr eq "PRECISION" and + return [ map { $sth->{f_overall_defs}{$_}{data_length} || 0 } + @colnames ]; + + $attr eq "NULLABLE" and + return [ map { ( grep { $_ eq "NOT NULL" } + @{ $sth->{f_overall_defs}{$_}{constraints} || [] }) + ? 0 : 1 } + @colnames ]; + } + } + + return $sth->SUPER::FETCH ($attr); + } # FETCH + +# ====== TableSource =========================================================== + +package DBD::File::TableSource::FileSystem; + +use strict; +use warnings; + +use IO::Dir; + +@DBD::File::TableSource::FileSystem::ISA = "DBI::DBD::SqlEngine::TableSource"; + +sub data_sources +{ + my ($class, $drh, $attr) = @_; + my $dir = $attr && exists $attr->{f_dir} + ? $attr->{f_dir} + : File::Spec->curdir (); + defined $dir or return; # Stream-based databases do not have f_dir + unless (-d $dir && -r $dir && -x $dir) { + $drh->set_err ($DBI::stderr, "Cannot use directory $dir from f_dir"); + return; + } + my %attrs; + $attr and %attrs = %$attr; + delete $attrs{f_dir}; + my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote"); + my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs; + my @dir = ($dir); + $attr->{f_dir_search} && ref $attr->{f_dir_search} eq "ARRAY" and + push @dir, grep { -d $_ } @{$attr->{f_dir_search}}; + my @dsns; + foreach $dir (@dir) { + my $dirh = IO::Dir->new ($dir); + unless (defined $dirh) { + $drh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); + return; + } + + my ($file, %names, $driver); + $driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 : "File"; + + while (defined ($file = $dirh->read ())) { + my $d = File::Spec->catdir ($dir, $file); + # allow current dir ... it can be a data_source too + $file ne File::Spec->updir () && -d $d and + push @dsns, "DBI:$driver:f_dir=" . &{$dsn_quote} ($d) . ($dsnextra ? ";$dsnextra" : ""); + } + } + return @dsns; + } # data_sources + +sub avail_tables +{ + my ($self, $dbh) = @_; + + my $dir = $dbh->{f_dir}; + defined $dir or return; # Stream based db's cannot be queried for tables + + my %seen; + my @tables; + my @dir = ($dir); + $dbh->{f_dir_search} && ref $dbh->{f_dir_search} eq "ARRAY" and + push @dir, grep { -d $_ } @{$dbh->{f_dir_search}}; + foreach $dir (@dir) { + my $dirh = IO::Dir->new ($dir); + + unless (defined $dirh) { + $dbh->set_err ($DBI::stderr, "Cannot open directory $dir: $!"); + return; + } + + my $class = $dbh->FETCH ("ImplementorClass"); + $class =~ s/::db$/::Table/; + my ($file, %names); + my $schema = exists $dbh->{f_schema} + ? defined $dbh->{f_schema} && $dbh->{f_schema} ne "" + ? $dbh->{f_schema} : undef + : eval { getpwuid ((stat $dir)[4]) }; # XXX Win32::pwent + while (defined ($file = $dirh->read ())) { + my ($tbl, $meta) = $class->get_table_meta ($dbh, $file, 0, 0) or next; # XXX + # $tbl && $meta && -f $meta->{f_fqfn} or next; + $seen{defined $schema ? $schema : "\0"}{$dir}{$tbl}++ or + push @tables, [ undef, $schema, $tbl, "TABLE", "FILE" ]; + } + $dirh->close () or + $dbh->set_err ($DBI::stderr, "Cannot close directory $dir: $!"); + } + + return @tables; + } # avail_tables + +# ====== DataSource ============================================================ + +package DBD::File::DataSource::Stream; + +use strict; +use warnings; + +use Carp; + +@DBD::File::DataSource::Stream::ISA = "DBI::DBD::SqlEngine::DataSource"; + +# We may have a working flock () built-in but that doesn't mean that locking +# will work on NFS (flock () may hang hard) +my $locking = eval { + my $fh; + my $nulldevice = File::Spec->devnull (); + open $fh, ">", $nulldevice or croak "Can't open $nulldevice: $!"; + flock $fh, 0; + close $fh; + 1; + }; + +sub complete_table_name +{ + my ($self, $meta, $file, $respect_case) = @_; + + my $tbl = $file; + if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER + $tbl = uc $tbl; + } + elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER + $tbl = lc $tbl; + } + + $meta->{f_fqfn} = undef; + $meta->{f_fqbn} = undef; + $meta->{f_fqln} = undef; + + $meta->{table_name} = $tbl; + + return $tbl; + } # complete_table_name + +sub apply_encoding +{ + my ($self, $meta, $fn) = @_; + defined $fn or $fn = "file handle " . fileno ($meta->{fh}); + if (my $enc = $meta->{f_encoding}) { + binmode $meta->{fh}, ":encoding($enc)" or + croak "Failed to set encoding layer '$enc' on $fn: $!"; + } + else { + binmode $meta->{fh} or croak "Failed to set binary mode on $fn: $!"; + } + } # apply_encoding + +sub open_data +{ + my ($self, $meta, $attrs, $flags) = @_; + + $flags->{dropMode} and croak "Can't drop a table in stream"; + my $fn = "file handle " . fileno ($meta->{f_file}); + + if ($flags->{createMode} || $flags->{lockMode}) { + $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "w+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + $meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "r") or + croak "Cannot open $fn for reading: $! (" . ($!+0) . ")"; + } + + if ($meta->{fh}) { + $self->apply_encoding ($meta, $fn); + } # have $meta->{$fh} + + if ($self->can_flock && $meta->{fh}) { + my $lm = defined $flags->{f_lock} + && $flags->{f_lock} =~ m/^[012]$/ + ? $flags->{f_lock} + : $flags->{lockMode} ? 2 : 1; + if ($lm == 2) { + flock $meta->{fh}, 2 or croak "Cannot obtain exclusive lock on $fn: $!"; + } + elsif ($lm == 1) { + flock $meta->{fh}, 1 or croak "Cannot obtain shared lock on $fn: $!"; + } + # $lm = 0 is forced no locking at all + } + } # open_data + +sub can_flock { $locking } + +package DBD::File::DataSource::File; + +use strict; +use warnings; + +@DBD::File::DataSource::File::ISA = "DBD::File::DataSource::Stream"; + +use Carp; + +my $fn_any_ext_regex = qr/\.[^.]*/; + +sub complete_table_name +{ + my ($self, $meta, $file, $respect_case, $file_is_table) = @_; + + $file eq "." || $file eq ".." and return; # XXX would break a possible DBD::Dir + + # XXX now called without proving f_fqfn first ... + my ($ext, $req) = ("", 0); + if ($meta->{f_ext}) { + ($ext, my $opt) = split m{/}, $meta->{f_ext}; + if ($ext && $opt) { + $opt =~ m/r/i and $req = 1; + } + } + + # (my $tbl = $file) =~ s/$ext$//i; + my ($tbl, $basename, $dir, $fn_ext, $user_spec_file, $searchdir); + if ($file_is_table and defined $meta->{f_file}) { + $tbl = $file; + ($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex); + $file = $basename . $fn_ext; + $user_spec_file = 1; + } + else { + ($basename, $dir, undef) = File::Basename::fileparse ($file, $ext); + # $dir is returned with trailing (back)slash. We just need to check + # if it is ".", "./", or ".\" or "[]" (VMS) + if ($dir =~ m{^(?:[.][/\\]?|\[\])$} && ref $meta->{f_dir_search} eq "ARRAY") { + foreach my $d ($meta->{f_dir}, @{$meta->{f_dir_search}}) { + my $f = File::Spec->catdir ($d, $file); + -f $f or next; + $searchdir = Cwd::abs_path ($d); + $dir = ""; + last; + } + } + $file = $tbl = $basename; + $user_spec_file = 0; + } + + if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER + $basename = uc $basename; + $tbl = uc $tbl; + } + elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER + $basename = lc $basename; + $tbl = lc $tbl; + } + + unless (defined $searchdir) { + $searchdir = File::Spec->file_name_is_absolute ($dir) + ? ($dir =~ s{/$}{}, $dir) + : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir)); + } + -d $searchdir or + croak "-d $searchdir: $!"; + + $searchdir eq $meta->{f_dir} and + $dir = ""; + + unless ($user_spec_file) { + $file_is_table and $file = "$basename$ext"; + + # Fully Qualified File Name + my $cmpsub; + if ($respect_case) { + $cmpsub = sub { + my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); + $^O eq "VMS" && $sfx eq "." and + $sfx = ""; # no extension turns up as a dot + $fn eq $basename and + return (lc $sfx eq lc $ext or !$req && !$sfx); + return 0; + } + } + else { + $cmpsub = sub { + my ($fn, undef, $sfx) = File::Basename::fileparse ($_, $fn_any_ext_regex); + $^O eq "VMS" && $sfx eq "." and + $sfx = ""; # no extension turns up as a dot + lc $fn eq lc $basename and + return (lc $sfx eq lc $ext or !$req && !$sfx); + return 0; + } + } + + my @f; + { my $dh = IO::Dir->new ($searchdir) or croak "Can't open '$searchdir': $!"; + @f = sort { length $b <=> length $a } + grep { &$cmpsub ($_) } + $dh->read (); + $dh->close () or croak "Can't close '$searchdir': $!"; + } + @f > 0 && @f <= 2 and $file = $f[0]; + !$respect_case && $meta->{sql_identifier_case} == 4 and # XXX SQL_IC_MIXED + ($tbl = $file) =~ s/$ext$//i; + + my $tmpfn = $file; + if ($ext && $req) { + # File extension required + $tmpfn =~ s/$ext$//i or return; + } + } + + my $fqfn = File::Spec->catfile ($searchdir, $file); + my $fqbn = File::Spec->catfile ($searchdir, $basename); + + $meta->{f_fqfn} = $fqfn; + $meta->{f_fqbn} = $fqbn; + defined $meta->{f_lockfile} && $meta->{f_lockfile} and + $meta->{f_fqln} = $meta->{f_fqbn} . $meta->{f_lockfile}; + + $dir && !$user_spec_file and $tbl = File::Spec->catfile ($dir, $tbl); + $meta->{table_name} = $tbl; + + return $tbl; + } # complete_table_name + +sub open_data +{ + my ($self, $meta, $attrs, $flags) = @_; + + defined $meta->{f_fqfn} && $meta->{f_fqfn} ne "" or croak "No filename given"; + + my ($fh, $fn); + unless ($meta->{f_dontopen}) { + $fn = $meta->{f_fqfn}; + if ($flags->{createMode}) { + -f $meta->{f_fqfn} and + croak "Cannot create table $attrs->{table}: Already exists"; + $fh = IO::File->new ($fn, "a+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { + croak "Cannot open $fn: $! (" . ($!+0) . ")"; + } + } + + $meta->{fh} = $fh; + + if ($fh) { + $fh->seek (0, 0) or + croak "Error while seeking back: $!"; + + $self->apply_encoding ($meta); + } + } + if ($meta->{f_fqln}) { + $fn = $meta->{f_fqln}; + if ($flags->{createMode}) { + -f $fn and + croak "Cannot create table lock at '$fn' for $attrs->{table}: Already exists"; + $fh = IO::File->new ($fn, "a+") or + croak "Cannot open $fn for writing: $! (" . ($!+0) . ")"; + } + else { + unless ($fh = IO::File->new ($fn, ($flags->{lockMode} ? "r+" : "r"))) { + croak "Cannot open $fn: $! (" . ($!+0) . ")"; + } + } + + $meta->{lockfh} = $fh; + } + + if ($self->can_flock && $fh) { + my $lm = defined $flags->{f_lock} + && $flags->{f_lock} =~ m/^[012]$/ + ? $flags->{f_lock} + : $flags->{lockMode} ? 2 : 1; + if ($lm == 2) { + flock $fh, 2 or croak "Cannot obtain exclusive lock on $fn: $!"; + } + elsif ($lm == 1) { + flock $fh, 1 or croak "Cannot obtain shared lock on $fn: $!"; + } + # $lm = 0 is forced no locking at all + } + } # open_data + +# ====== SQL::STATEMENT ======================================================== + +package DBD::File::Statement; + +use strict; +use warnings; + +@DBD::File::Statement::ISA = qw( DBI::DBD::SqlEngine::Statement ); + +# ====== SQL::TABLE ============================================================ + +package DBD::File::Table; + +use strict; +use warnings; + +use Carp; +require IO::File; +require File::Basename; +require File::Spec; +require Cwd; +require Scalar::Util; + +@DBD::File::Table::ISA = qw( DBI::DBD::SqlEngine::Table ); + +# ====== UTILITIES ============================================================ + +if (eval { require Params::Util; }) { + Params::Util->import ("_HANDLE"); + } +else { + # taken but modified from Params::Util ... + *_HANDLE = sub { + # It has to be defined, of course + defined $_[0] or return; + + # Normal globs are considered to be file handles + ref $_[0] eq "GLOB" and return $_[0]; + + # Check for a normal tied filehandle + # Side Note: 5.5.4's tied () and can () doesn't like getting undef + tied ($_[0]) and tied ($_[0])->can ("TIEHANDLE") and return $_[0]; + + # There are no other non-object handles that we support + Scalar::Util::blessed ($_[0]) or return; + + # Check for a common base classes for conventional IO::Handle object + $_[0]->isa ("IO::Handle") and return $_[0]; + + # Check for tied file handles using Tie::Handle + $_[0]->isa ("Tie::Handle") and return $_[0]; + + # IO::Scalar is not a proper seekable, but it is valid is a + # regular file handle + $_[0]->isa ("IO::Scalar") and return $_[0]; + + # Yet another special case for IO::String, which refuses (for now + # anyway) to become a subclass of IO::Handle. + $_[0]->isa ("IO::String") and return $_[0]; + + # This is not any sort of object we know about + return; + }; + } + +# ====== FLYWEIGHT SUPPORT ===================================================== + +# Flyweight support for table_info +# The functions file2table, init_table_meta, default_table_meta and +# get_table_meta are using $self arguments for polymorphism only. The +# must not rely on an instantiated DBD::File::Table +sub file2table +{ + my ($self, $meta, $file, $file_is_table, $respect_case) = @_; + + return $meta->{sql_data_source}->complete_table_name ($meta, $file, $respect_case, $file_is_table); + } # file2table + +sub bootstrap_table_meta +{ + my ($self, $dbh, $meta, $table, @other) = @_; + + $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table, @other); + + exists $meta->{f_dir} or $meta->{f_dir} = $dbh->{f_dir}; + exists $meta->{f_dir_search} or $meta->{f_dir_search} = $dbh->{f_dir_search}; + defined $meta->{f_ext} or $meta->{f_ext} = $dbh->{f_ext}; + defined $meta->{f_encoding} or $meta->{f_encoding} = $dbh->{f_encoding}; + exists $meta->{f_lock} or $meta->{f_lock} = $dbh->{f_lock}; + exists $meta->{f_lockfile} or $meta->{f_lockfile} = $dbh->{f_lockfile}; + defined $meta->{f_schema} or $meta->{f_schema} = $dbh->{f_schema}; + + defined $meta->{f_open_file_needed} or + $meta->{f_open_file_needed} = $self->can ("open_file") != DBD::File::Table->can ("open_file"); + + defined ($meta->{sql_data_source}) or + $meta->{sql_data_source} = _HANDLE ($meta->{f_file}) + ? "DBD::File::DataSource::Stream" + : "DBD::File::DataSource::File"; + } # bootstrap_table_meta + +sub get_table_meta ($$$$;$) +{ + my ($self, $dbh, $table, $file_is_table, $respect_case) = @_; + + my $meta = $self->SUPER::get_table_meta ($dbh, $table, $respect_case, $file_is_table); + $table = $meta->{table_name}; + return unless $table; + + return ($table, $meta); + } # get_table_meta + +my %reset_on_modify = ( + f_file => [ "f_fqfn", "sql_data_source" ], + f_dir => "f_fqfn", + f_dir_search => [], + f_ext => "f_fqfn", + f_lockfile => "f_fqfn", # forces new file2table call + ); + +__PACKAGE__->register_reset_on_modify (\%reset_on_modify); + +my %compat_map = map { $_ => "f_$_" } qw( file ext lock lockfile ); + +__PACKAGE__->register_compat_map (\%compat_map); + +# ====== DBD::File <= 0.40 compat stuff ======================================== + +# compat to 0.38 .. 0.40 API +sub open_file +{ + my ($className, $meta, $attrs, $flags) = @_; + + return $className->SUPER::open_data ($meta, $attrs, $flags); + } # open_file + +sub open_data +{ + my ($className, $meta, $attrs, $flags) = @_; + + # compat to 0.38 .. 0.40 API + $meta->{f_open_file_needed} + ? $className->open_file ($meta, $attrs, $flags) + : $className->SUPER::open_data ($meta, $attrs, $flags); + + return; + } # open_data + +# ====== SQL::Eval API ========================================================= + +sub drop ($) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + # We have to close the file before unlinking it: Some OS'es will + # refuse the unlink otherwise. + $meta->{fh} and $meta->{fh}->close (); + $meta->{lockfh} and $meta->{lockfh}->close (); + undef $meta->{fh}; + undef $meta->{lockfh}; + $meta->{f_fqfn} and unlink $meta->{f_fqfn}; # XXX ==> sql_data_source + $meta->{f_fqln} and unlink $meta->{f_fqln}; # XXX ==> sql_data_source + delete $data->{Database}{sql_meta}{$self->{table}}; + return 1; + } # drop + +sub seek ($$$$) +{ + my ($self, $data, $pos, $whence) = @_; + my $meta = $self->{meta}; + if ($whence == 0 && $pos == 0) { + $pos = defined $meta->{first_row_pos} ? $meta->{first_row_pos} : 0; + } + elsif ($whence != 2 || $pos != 0) { + croak "Illegal seek position: pos = $pos, whence = $whence"; + } + + $meta->{fh}->seek ($pos, $whence) or + croak "Error while seeking in " . $meta->{f_fqfn} . ": $!"; + } # seek + +sub truncate ($$) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + $meta->{fh}->truncate ($meta->{fh}->tell ()) or + croak "Error while truncating " . $meta->{f_fqfn} . ": $!"; + return 1; + } # truncate + +sub DESTROY +{ + my $self = shift; + my $meta = $self->{meta}; + $meta->{fh} and $meta->{fh}->close (); + $meta->{lockfh} and $meta->{lockfh}->close (); + undef $meta->{fh}; + undef $meta->{lockfh}; + + $self->SUPER::DESTROY(); + } # DESTROY + +1; + +__END__ + +#line 1450 diff --git a/apps/lib/DBD/Gofer.pm b/apps/lib/DBD/Gofer.pm new file mode 100644 index 0000000..c23ba78 --- /dev/null +++ b/apps/lib/DBD/Gofer.pm @@ -0,0 +1,814 @@ +#line 1 "DBD/Gofer.pm" +{ + package DBD::Gofer; + + use strict; + + require DBI; + require DBI::Gofer::Request; + require DBI::Gofer::Response; + require Carp; + + our $VERSION = "0.015327"; + +# $Id: Gofer.pm 15326 2012-06-06 16:32:38Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + + + # attributes we'll allow local STORE + our %xxh_local_store_attrib = map { $_=>1 } qw( + Active + CachedKids + Callbacks + DbTypeSubclass + ErrCount Executed + FetchHashKeyName + HandleError HandleSetErr + InactiveDestroy + AutoInactiveDestroy + PrintError PrintWarn + Profile + RaiseError + RootClass + ShowErrorStatement + Taint TaintIn TaintOut + TraceLevel + Warn + dbi_quote_identifier_cache + dbi_connect_closure + dbi_go_execute_unique + ); + our %xxh_local_store_attrib_if_same_value = map { $_=>1 } qw( + Username + dbi_connect_method + ); + + our $drh = undef; # holds driver handle once initialized + our $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBI->setup_driver('DBD::Gofer'); + + unless ($methods_already_installed++) { + my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR + DBD::Gofer::db->install_method('go_dbh_method', $opts); + DBD::Gofer::st->install_method('go_sth_method', $opts); + DBD::Gofer::st->install_method('go_clone_sth', $opts); + DBD::Gofer::db->install_method('go_cache', $opts); + DBD::Gofer::st->install_method('go_cache', $opts); + } + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Gofer', + 'Version' => $VERSION, + 'Attribution' => 'DBD Gofer by Tim Bunce', + }); + + $drh; + } + + + sub CLONE { + undef $drh; + } + + + sub go_cache { + my $h = shift; + $h->{go_cache} = shift if @_; + # return handle's override go_cache, if it has one + return $h->{go_cache} if defined $h->{go_cache}; + # or else the transports default go_cache + return $h->{go_transport}->{go_cache}; + } + + + sub set_err_from_response { # set error/warn/info and propagate warnings + my $h = shift; + my $response = shift; + if (my $warnings = $response->warnings) { + warn $_ for @$warnings; + } + my ($err, $errstr, $state) = $response->err_errstr_state; + # Only set_err() if there's an error else leave the current values + # (The current values will normally be set undef by the DBI dispatcher + # except for methods marked KEEPERR such as ping.) + $h->set_err($err, $errstr, $state) if defined $err; + return undef; + } + + + sub install_methods_proxy { + my ($installed_methods) = @_; + while ( my ($full_method, $attr) = each %$installed_methods ) { + # need to install both a DBI dispatch stub and a proxy stub + # (the dispatch stub may be already here due to local driver use) + + DBI->_install_method($full_method, "", $attr||{}) + unless defined &{$full_method}; + + # now install proxy stubs on the driver side + $full_method =~ m/^DBI::(\w\w)::(\w+)$/ + or die "Invalid method name '$full_method' for install_method"; + my ($type, $method) = ($1, $2); + my $driver_method = "DBD::Gofer::${type}::${method}"; + next if defined &{$driver_method}; + my $sub; + if ($type eq 'db') { + $sub = sub { return shift->go_dbh_method(undef, $method, @_) }; + } + else { + $sub = sub { shift->set_err($DBI::stderr, "Can't call \$${type}h->$method when using DBD::Gofer"); return; }; + } + no strict 'refs'; + *$driver_method = $sub; + } + } +} + + +{ package DBD::Gofer::dr; # ====== DRIVER ====== + + $imp_data_size = 0; + use strict; + + sub connect_cached { + my ($drh, $dsn, $user, $auth, $attr)= @_; + $attr ||= {}; + return $drh->SUPER::connect_cached($dsn, $user, $auth, { + (%$attr), + go_connect_method => $attr->{go_connect_method} || 'connect_cached', + }); + } + + + sub connect { + my($drh, $dsn, $user, $auth, $attr)= @_; + my $orig_dsn = $dsn; + + # first remove dsn= and everything after it + my $remote_dsn = ($dsn =~ s/;?\bdsn=(.*)$// && $1) + or return $drh->set_err($DBI::stderr, "No dsn= argument in '$orig_dsn'"); + + if ($attr->{go_bypass}) { # don't use DBD::Gofer for this connection + # useful for testing with DBI_AUTOPROXY, e.g., t/03handle.t + return DBI->connect($remote_dsn, $user, $auth, $attr); + } + + my %go_attr; + # extract any go_ attributes from the connect() attr arg + for my $k (grep { /^go_/ } keys %$attr) { + $go_attr{$k} = delete $attr->{$k}; + } + # then override those with any attributes embedded in our dsn (not remote_dsn) + for my $kv (grep /=/, split /;/, $dsn, -1) { + my ($k, $v) = split /=/, $kv, 2; + $go_attr{ "go_$k" } = $v; + } + + if (not ref $go_attr{go_policy}) { # if not a policy object already + my $policy_class = $go_attr{go_policy} || 'classic'; + $policy_class = "DBD::Gofer::Policy::$policy_class" + unless $policy_class =~ /::/; + _load_class($policy_class) + or return $drh->set_err($DBI::stderr, "Can't load $policy_class: $@"); + # replace policy name in %go_attr with policy object + $go_attr{go_policy} = eval { $policy_class->new(\%go_attr) } + or return $drh->set_err($DBI::stderr, "Can't instanciate $policy_class: $@"); + } + # policy object is left in $go_attr{go_policy} so transport can see it + my $go_policy = $go_attr{go_policy}; + + if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a cache object already + my $cache_class = $go_attr{go_cache}; + $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1'; + _load_class($cache_class) + or return $drh->set_err($DBI::stderr, "Can't load $cache_class $@"); + $go_attr{go_cache} = eval { $cache_class->new() } + or $drh->set_err(0, "Can't instanciate $cache_class: $@"); # warning + } + + # delete any other attributes that don't apply to transport + my $go_connect_method = delete $go_attr{go_connect_method}; + + my $transport_class = delete $go_attr{go_transport} + or return $drh->set_err($DBI::stderr, "No transport= argument in '$orig_dsn'"); + $transport_class = "DBD::Gofer::Transport::$transport_class" + unless $transport_class =~ /::/; + _load_class($transport_class) + or return $drh->set_err($DBI::stderr, "Can't load $transport_class: $@"); + my $go_transport = eval { $transport_class->new(\%go_attr) } + or return $drh->set_err($DBI::stderr, "Can't instanciate $transport_class: $@"); + + my $request_class = "DBI::Gofer::Request"; + my $go_request = eval { + my $go_attr = { %$attr }; + # XXX user/pass of fwd server vs db server ? also impact of autoproxy + if ($user) { + $go_attr->{Username} = $user; + $go_attr->{Password} = $auth; + } + # delete any attributes we can't serialize (or don't want to) + delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)}; + # delete any attributes that should only apply to the client-side + delete @{$go_attr}{qw(RootClass DbTypeSubclass)}; + + $go_connect_method ||= $go_policy->connect_method($remote_dsn, $go_attr) || 'connect'; + $request_class->new({ + dbh_connect_call => [ $go_connect_method, $remote_dsn, $user, $auth, $go_attr ], + }) + } or return $drh->set_err($DBI::stderr, "Can't instanciate $request_class: $@"); + + my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, { + 'Name' => $dsn, + 'USER' => $user, + go_transport => $go_transport, + go_request => $go_request, + go_policy => $go_policy, + }); + + # mark as inactive temporarily for STORE. Active not set until connected() called. + $dbh->STORE(Active => 0); + + # should we ping to check the connection + # and fetch dbh attributes + my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh); + if (not $skip_connect_check) { + if (not $dbh->go_dbh_method(undef, 'ping')) { + return undef if $dbh->err; # error already recorded, typically + return $dbh->set_err($DBI::stderr, "ping failed"); + } + } + + return $dbh; + } + + sub _load_class { # return true or false+$@ + my $class = shift; + (my $pm = $class) =~ s{::}{/}g; + $pm .= ".pm"; + return 1 if eval { require $pm }; + delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning undef isn't enough + undef; # error in $@ + } + +} + + +{ package DBD::Gofer::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + use Carp qw(carp croak); + + my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib; + + sub connected { + shift->STORE(Active => 1); + } + + sub go_dbh_method { + my $dbh = shift; + my $meta = shift; + # @_ now contains ($method_name, @args) + + my $request = $dbh->{go_request}; + $request->init_request([ wantarray, @_ ], $dbh); + ++$dbh->{go_request_count}; + + my $go_policy = $dbh->{go_policy}; + my $dbh_attribute_update = $go_policy->dbh_attribute_update(); + $request->dbh_attributes( $go_policy->dbh_attribute_list() ) + if $dbh_attribute_update eq 'every' + or $dbh->{go_request_count}==1; + + $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) + if $meta->{go_last_insert_id_args}; + + my $transport = $dbh->{go_transport} + or return $dbh->set_err($DBI::stderr, "Not connected (no transport)"); + + local $transport->{go_cache} = $dbh->{go_cache} + if defined $dbh->{go_cache}; + + my ($response, $retransmit_sub) = $transport->transmit_request($request); + $response ||= $transport->receive_response($request, $retransmit_sub); + $dbh->{go_response} = $response + or die "No response object returned by $transport"; + + die "response '$response' returned by $transport is not a response object" + unless UNIVERSAL::isa($response,"DBI::Gofer::Response"); + + if (my $dbh_attributes = $response->dbh_attributes) { + + # XXX installed_methods piggybacks on dbh_attributes for now + if (my $installed_methods = delete $dbh_attributes->{dbi_installed_methods}) { + DBD::Gofer::install_methods_proxy($installed_methods) + if $dbh->{go_request_count}==1; + } + + # XXX we don't STORE here, we just stuff the value into the attribute cache + $dbh->{$_} = $dbh_attributes->{$_} + for keys %$dbh_attributes; + } + + my $rv = $response->rv; + if (my $resultset_list = $response->sth_resultsets) { + # dbh method call returned one or more resultsets + # (was probably a metadata method like table_info) + # + # setup an sth but don't execute/forward it + my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 }); + # set the sth response to our dbh response + (tied %$sth)->{go_response} = $response; + # setup the sth with the results in our response + $sth->more_results; + # and return that new sth as if it came from original request + $rv = [ $sth ]; + } + elsif (!$rv) { # should only occur for major transport-level error + #carp("no rv in response { @{[ %$response ]} }"); + $rv = [ ]; + } + + DBD::Gofer::set_err_from_response($dbh, $response); + + return (wantarray) ? @$rv : $rv->[0]; + } + + + # Methods that should be forwarded but can be cached + for my $method (qw( + tables table_info column_info primary_key_info foreign_key_info statistics_info + data_sources type_info_all get_info + parse_trace_flags parse_trace_flag + func + )) { + my $policy_name = "cache_$method"; + my $super_name = "SUPER::$method"; + my $sub = sub { + my $dbh = shift; + my $rv; + + # if we know the remote side doesn't override the DBI's default method + # then we might as well just call the DBI's default method on the client + # (which may, in turn, call other methods that are forwarded, like get_info) + if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { + $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); + return $dbh->$super_name(@_); + } + + my $cache; + my $cache_key; + if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh, @_)) { + $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from go_cache + $cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0, + join(",\t", map { # XXX basic but sufficient for now + !ref($_) ? DBI::neat($_,1e6) + : ref($_) eq 'ARRAY' ? DBI::neat_list($_,1e6,",\001") + : ref($_) eq 'HASH' ? do { my @k = sort keys %$_; DBI::neat_list([@k,@{$_}{@k}],1e6,",\002") } + : do { warn "unhandled argument type ($_)"; $_ } + } @_); + if ($rv = $cache->{$cache_key}) { + $dbh->trace_msg("$method(@_) returning previously cached value ($cache_key)\n",4); + my @cache_rv = @$rv; + # if it's an sth we have to clone it + $cache_rv[0] = $cache_rv[0]->go_clone_sth if UNIVERSAL::isa($cache_rv[0],'DBI::st'); + return (wantarray) ? @cache_rv : $cache_rv[0]; + } + } + + $rv = [ (wantarray) + ? ($dbh->go_dbh_method(undef, $method, @_)) + : scalar $dbh->go_dbh_method(undef, $method, @_) + ]; + + if ($cache) { + $dbh->trace_msg("$method(@_) caching return value ($cache_key)\n",4); + my @cache_rv = @$rv; + # if it's an sth we have to clone it + #$cache_rv[0] = $cache_rv[0]->go_clone_sth + # if UNIVERSAL::isa($cache_rv[0],'DBI::st'); + $cache->{$cache_key} = \@cache_rv + unless UNIVERSAL::isa($cache_rv[0],'DBI::st'); # XXX cloning sth not yet done + } + + return (wantarray) ? @$rv : $rv->[0]; + }; + no strict 'refs'; + *$method = $sub; + } + + + # Methods that can use the DBI defaults for some situations/drivers + for my $method (qw( + quote quote_identifier + )) { # XXX keep DBD::Gofer::Policy::Base in sync + my $policy_name = "locally_$method"; + my $super_name = "SUPER::$method"; + my $sub = sub { + my $dbh = shift; + + # if we know the remote side doesn't override the DBI's default method + # then we might as well just call the DBI's default method on the client + # (which may, in turn, call other methods that are forwarded, like get_info) + if ($dbh->{dbi_default_methods}{$method} && $dbh->{go_policy}->skip_default_methods()) { + $dbh->trace_msg(" !! $method: using local default as remote method is also default\n"); + return $dbh->$super_name(@_); + } + + # false: use remote gofer + # 1: use local DBI default method + # code ref: use the code ref + my $locally = $dbh->{go_policy}->$policy_name($dbh, @_); + if ($locally) { + return $locally->($dbh, @_) if ref $locally eq 'CODE'; + return $dbh->$super_name(@_); + } + return $dbh->go_dbh_method(undef, $method, @_); # propagate context + }; + no strict 'refs'; + *$method = $sub; + } + + + # Methods that should always fail + for my $method (qw( + begin_work commit rollback + )) { + no strict 'refs'; + *$method = sub { return shift->set_err($DBI::stderr, "$method not available with DBD::Gofer") } + } + + + sub do { + my ($dbh, $sql, $attr, @args) = @_; + delete $dbh->{Statement}; # avoid "Modification of non-creatable hash value attempted" + $dbh->{Statement} = $sql; # for profiling and ShowErrorStatement + my $meta = { go_last_insert_id_args => $attr->{go_last_insert_id_args} }; + return $dbh->go_dbh_method($meta, 'do', $sql, $attr, @args); + } + + sub ping { + my $dbh = shift; + return $dbh->set_err('', "can't ping while not connected") # info + unless $dbh->SUPER::FETCH('Active'); + my $skip_ping = $dbh->{go_policy}->skip_ping(); + return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_); + } + + sub last_insert_id { + my $dbh = shift; + my $response = $dbh->{go_response} or return undef; + return $response->last_insert_id; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + + # FETCH is effectively already cached because the DBI checks the + # attribute cache in the handle before calling FETCH + # and this FETCH copies the value into the attribute cache + + # forward driver-private attributes (except ours) + if ($attrib =~ m/^[a-z]/ && $attrib !~ /^go_/) { + my $value = $dbh->go_dbh_method(undef, 'FETCH', $attrib); + $dbh->{$attrib} = $value; # XXX forces caching by DBI + return $dbh->{$attrib} = $value; + } + + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + if ($attrib eq 'AutoCommit') { + croak "Can't enable transactions when using DBD::Gofer" if !$value; + return $dbh->SUPER::STORE($attrib => ($value) ? -901 : -900); + } + return $dbh->SUPER::STORE($attrib => $value) + # we handle this attribute locally + if $dbh_local_store_attrib{$attrib} + # or it's a private_ (application) attribute + or $attrib =~ /^private_/ + # or not yet connected (ie being called by DBI->connect) + or not $dbh->FETCH('Active'); + + return $dbh->SUPER::STORE($attrib => $value) + if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib} + && do { # values are the same + my $crnt = $dbh->FETCH($attrib); + local $^W; + (defined($value) ^ defined($crnt)) + ? 0 # definedness differs + : $value eq $crnt; + }; + + # dbh attributes are set at connect-time - see connect() + carp("Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer") if $dbh->FETCH('Warn'); + return $dbh->set_err($DBI::stderr, "Can't alter \$dbh->{$attrib} after handle created with DBD::Gofer"); + } + + sub disconnect { + my $dbh = shift; + $dbh->{go_transport} = undef; + $dbh->STORE(Active => 0); + } + + sub prepare { + my ($dbh, $statement, $attr)= @_; + + return $dbh->set_err($DBI::stderr, "Can't prepare when disconnected") + unless $dbh->FETCH('Active'); + + $attr = { %$attr } if $attr; # copy so we can edit + + my $policy = delete($attr->{go_policy}) || $dbh->{go_policy}; + my $lii_args = delete $attr->{go_last_insert_id_args}; + my $go_prepare = delete($attr->{go_prepare_method}) + || $dbh->{go_prepare_method} + || $policy->prepare_method($dbh, $statement, $attr) + || 'prepare'; # e.g. for code not using placeholders + my $go_cache = delete $attr->{go_cache}; + # set to undef if there are no attributes left for the actual prepare call + $attr = undef if $attr and not %$attr; + + my ($sth, $sth_inner) = DBI::_new_sth($dbh, { + Statement => $statement, + go_prepare_call => [ 0, $go_prepare, $statement, $attr ], + # go_method_calls => [], # autovivs if needed + go_request => $dbh->{go_request}, + go_transport => $dbh->{go_transport}, + go_policy => $policy, + go_last_insert_id_args => $lii_args, + go_cache => $go_cache, + }); + $sth->STORE(Active => 0); # XXX needed? It should be the default + + my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh, $statement, $attr, $sth); + if (not $skip_prepare_check) { + $sth->go_sth_method() or return undef; + } + + return $sth; + } + + sub prepare_cached { + my ($dbh, $sql, $attr, $if_active)= @_; + $attr ||= {}; + return $dbh->SUPER::prepare_cached($sql, { + %$attr, + go_prepare_method => $attr->{go_prepare_method} || 'prepare_cached', + }, $if_active); + } + + *go_cache = \&DBD::Gofer::go_cache; +} + + +{ package DBD::Gofer::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; + + my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib, NUM_OF_FIELDS => 1); + + sub go_sth_method { + my ($sth, $meta) = @_; + + if (my $ParamValues = $sth->{ParamValues}) { + my $ParamAttr = $sth->{ParamAttr}; + # XXX the sort here is a hack to work around a DBD::Sybase bug + # but only works properly for params 1..9 + # (reverse because of the unshift) + my @params = reverse sort keys %$ParamValues; + if (@params > 9 && ($sth->{Database}{go_dsn}||'') =~ /dbi:Sybase/) { + # if more than 9 then we need to do a proper numeric sort + # also warn to alert user of this issue + warn "Sybase param binding order hack in use"; + @params = sort { $b <=> $a } @params; + } + for my $p (@params) { + # unshift to put binds before execute call + unshift @{ $sth->{go_method_calls} }, + [ 'bind_param', $p, $ParamValues->{$p}, $ParamAttr->{$p} ]; + } + } + + my $dbh = $sth->{Database} or die "panic"; + ++$dbh->{go_request_count}; + + my $request = $sth->{go_request}; + $request->init_request($sth->{go_prepare_call}, $sth); + $request->sth_method_calls(delete $sth->{go_method_calls}) + if $sth->{go_method_calls}; + $request->sth_result_attr({}); # (currently) also indicates this is an sth request + + $request->dbh_last_insert_id_args($meta->{go_last_insert_id_args}) + if $meta->{go_last_insert_id_args}; + + my $go_policy = $sth->{go_policy}; + my $dbh_attribute_update = $go_policy->dbh_attribute_update(); + $request->dbh_attributes( $go_policy->dbh_attribute_list() ) + if $dbh_attribute_update eq 'every' + or $dbh->{go_request_count}==1; + + my $transport = $sth->{go_transport} + or return $sth->set_err($DBI::stderr, "Not connected (no transport)"); + + local $transport->{go_cache} = $sth->{go_cache} + if defined $sth->{go_cache}; + + my ($response, $retransmit_sub) = $transport->transmit_request($request); + $response ||= $transport->receive_response($request, $retransmit_sub); + $sth->{go_response} = $response + or die "No response object returned by $transport"; + $dbh->{go_response} = $response; # mainly for last_insert_id + + if (my $dbh_attributes = $response->dbh_attributes) { + # XXX we don't STORE here, we just stuff the value into the attribute cache + $dbh->{$_} = $dbh_attributes->{$_} + for keys %$dbh_attributes; + # record the values returned, so we know that we have fetched + # values are which we have fetched (see dbh->FETCH method) + $dbh->{go_dbh_attributes_fetched} = $dbh_attributes; + } + + my $rv = $response->rv; # may be undef on error + if ($response->sth_resultsets) { + # setup first resultset - including sth attributes + $sth->more_results; + } + else { + $sth->STORE(Active => 0); + $sth->{go_rows} = $rv; + } + # set error/warn/info (after more_results as that'll clear err) + DBD::Gofer::set_err_from_response($sth, $response); + + return $rv; + } + + + sub bind_param { + my ($sth, $param, $value, $attr) = @_; + $sth->{ParamValues}{$param} = $value; + $sth->{ParamAttr}{$param} = $attr + if defined $attr; # attr is sticky if not explicitly set + return 1; + } + + + sub execute { + my $sth = shift; + $sth->bind_param($_, $_[$_-1]) for (1..@_); + push @{ $sth->{go_method_calls} }, [ 'execute' ]; + my $meta = { go_last_insert_id_args => $sth->{go_last_insert_id_args} }; + return $sth->go_sth_method($meta); + } + + + sub more_results { + my $sth = shift; + + $sth->finish; + + my $response = $sth->{go_response} or do { + # e.g., we haven't sent a request yet (ie prepare then more_results) + $sth->trace_msg(" No response object present", 3); + return; + }; + + my $resultset_list = $response->sth_resultsets + or return $sth->set_err($DBI::stderr, "No sth_resultsets"); + + my $meta = shift @$resultset_list + or return undef; # no more result sets + #warn "more_results: ".Data::Dumper::Dumper($meta); + + # pull out the special non-attributes first + my ($rowset, $err, $errstr, $state) + = delete @{$meta}{qw(rowset err errstr state)}; + + # copy meta attributes into attribute cache + my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS}; + $sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS); + # XXX need to use STORE for some? + $sth->{$_} = $meta->{$_} for keys %$meta; + + if (($NUM_OF_FIELDS||0) > 0) { + $sth->{go_rows} = ($rowset) ? @$rowset : -1; + $sth->{go_current_rowset} = $rowset; + $sth->{go_current_rowset_err} = [ $err, $errstr, $state ] + if defined $err; + $sth->STORE(Active => 1) if $rowset; + } + + return $sth; + } + + + sub go_clone_sth { + my ($sth1) = @_; + # clone an (un-fetched-from) sth - effectively undoes the initial more_results + # not 100% so just for use in caching returned sth e.g. table_info + my $sth2 = $sth1->{Database}->prepare($sth1->{Statement}, { go_skip_prepare_check => 1 }); + $sth2->STORE($_, $sth1->{$_}) for qw(NUM_OF_FIELDS Active); + my $sth2_inner = tied %$sth2; + $sth2_inner->{$_} = $sth1->{$_} for qw(NUM_OF_PARAMS FetchHashKeyName); + die "not fully implemented yet"; + return $sth2; + } + + + sub fetchrow_arrayref { + my ($sth) = @_; + my $resultset = $sth->{go_current_rowset} || do { + # should only happen if fetch called after execute failed + my $rowset_err = $sth->{go_current_rowset_err} + || [ 1, 'no result set (did execute fail)' ]; + return $sth->set_err( @$rowset_err ); + }; + return $sth->_set_fbav(shift @$resultset) if @$resultset; + $sth->finish; # no more data so finish + return undef; + } + *fetch = \&fetchrow_arrayref; # alias + + + sub fetchall_arrayref { + my ($sth, $slice, $max_rows) = @_; + my $resultset = $sth->{go_current_rowset} || do { + # should only happen if fetch called after execute failed + my $rowset_err = $sth->{go_current_rowset_err} + || [ 1, 'no result set (did execute fail)' ]; + return $sth->set_err( @$rowset_err ); + }; + my $mode = ref($slice) || 'ARRAY'; + return $sth->SUPER::fetchall_arrayref($slice, $max_rows) + if ref($slice) or defined $max_rows; + $sth->finish; # no more data after this so finish + return $resultset; + } + + + sub rows { + return shift->{go_rows}; + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + + return $sth->SUPER::STORE($attrib => $value) + if $sth_local_store_attrib{$attrib} # handle locally + # or it's a private_ (application) attribute + or $attrib =~ /^private_/; + + # otherwise warn but do it anyway + # this will probably need refining later + my $msg = "Altering \$sth->{$attrib} won't affect proxied handle"; + Carp::carp($msg) if $sth->FETCH('Warn'); + + # XXX could perhaps do + # push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ] + # if not $sth->FETCH('Executed'); + # but how to handle repeat executions? How to we know when an + # attribute is being set to affect the current resultset or the + # next execution? + # Could just always use go_method_calls I guess. + + # do the store locally anyway, just in case + $sth->SUPER::STORE($attrib => $value); + + return $sth->set_err($DBI::stderr, $msg); + } + + # sub bind_param_array + # we use DBI's default, which sets $sth->{ParamArrays}{$param} = $value + # and calls bind_param($param, undef, $attr) if $attr. + + sub execute_array { + my $sth = shift; + my $attr = shift; + $sth->bind_param_array($_, $_[$_-1]) for (1..@_); + push @{ $sth->{go_method_calls} }, [ 'execute_array', $attr ]; + return $sth->go_sth_method($attr); + } + + *go_cache = \&DBD::Gofer::go_cache; +} + +1; + +__END__ + +#line 1293 diff --git a/apps/lib/DBD/Gofer/Policy/Base.pm b/apps/lib/DBD/Gofer/Policy/Base.pm new file mode 100644 index 0000000..32d6651 --- /dev/null +++ b/apps/lib/DBD/Gofer/Policy/Base.pm @@ -0,0 +1,88 @@ +#line 1 "DBD/Gofer/Policy/Base.pm" +package DBD::Gofer::Policy::Base; + +# $Id: Base.pm 10087 2007-10-16 12:42:37Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; +use Carp; + +our $VERSION = "0.010088"; +our $AUTOLOAD; + +my %policy_defaults = ( + # force connect method (unless overridden by go_connect_method=>'...' attribute) + # if false: call same method on client as on server + connect_method => 'connect', + # force prepare method (unless overridden by go_prepare_method=>'...' attribute) + # if false: call same method on client as on server + prepare_method => 'prepare', + skip_connect_check => 0, + skip_default_methods => 0, + skip_prepare_check => 0, + skip_ping => 0, + dbh_attribute_update => 'every', + dbh_attribute_list => ['*'], + locally_quote => 0, + locally_quote_identifier => 0, + cache_parse_trace_flags => 1, + cache_parse_trace_flag => 1, + cache_data_sources => 1, + cache_type_info_all => 1, + cache_tables => 0, + cache_table_info => 0, + cache_column_info => 0, + cache_primary_key_info => 0, + cache_foreign_key_info => 0, + cache_statistics_info => 0, + cache_get_info => 0, + cache_func => 0, +); + +my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"}; + +__PACKAGE__->create_policy_subs(\%policy_defaults); + +sub create_policy_subs { + my ($class, $policy_defaults) = @_; + + while ( my ($policy_name, $policy_default) = each %$policy_defaults) { + my $policy_attr_name = "go_$policy_name"; + my $sub = sub { + # $policy->foo($attr, ...) + #carp "$policy_name($_[1],...)"; + # return the policy default value unless an attribute overrides it + return (ref $_[1] && exists $_[1]->{$policy_attr_name}) + ? $_[1]->{$policy_attr_name} + : $policy_default; + }; + no strict 'refs'; + *{$class . '::' . $policy_name} = $sub; + } +} + +sub AUTOLOAD { + carp "Unknown policy name $AUTOLOAD used"; + # only warn once + no strict 'refs'; + *$AUTOLOAD = sub { undef }; + return undef; +} + +sub new { + my ($class, $args) = @_; + my $policy = {}; + bless $policy, $class; +} + +sub DESTROY { }; + +1; + +#line 162 + diff --git a/apps/lib/DBD/Gofer/Policy/classic.pm b/apps/lib/DBD/Gofer/Policy/classic.pm new file mode 100644 index 0000000..b67a2f7 --- /dev/null +++ b/apps/lib/DBD/Gofer/Policy/classic.pm @@ -0,0 +1,53 @@ +#line 1 "DBD/Gofer/Policy/classic.pm" +package DBD::Gofer::Policy::classic; + +# $Id: classic.pm 10087 2007-10-16 12:42:37Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +our $VERSION = "0.010088"; + +use base qw(DBD::Gofer::Policy::Base); + +__PACKAGE__->create_policy_subs({ + + # always use connect_cached on server + connect_method => 'connect_cached', + + # use same methods on server as is called on client + prepare_method => '', + + # don't skip the connect check since that also sets dbh attributes + # although this makes connect more expensive, that's partly offset + # by skip_ping=>1 below, which makes connect_cached very fast. + skip_connect_check => 0, + + # most code doesn't rely on sth attributes being set after prepare + skip_prepare_check => 1, + + # we're happy to use local method if that's the same as the remote + skip_default_methods => 1, + + # ping is not important for DBD::Gofer and most transports + skip_ping => 1, + + # only update dbh attributes on first contact with server + dbh_attribute_update => 'first', + + # we'd like to set locally_* but can't because drivers differ + + # get_info results usually don't change + cache_get_info => 1, +}); + + +1; + +#line 79 + diff --git a/apps/lib/DBD/Gofer/Policy/pedantic.pm b/apps/lib/DBD/Gofer/Policy/pedantic.pm new file mode 100644 index 0000000..7108722 --- /dev/null +++ b/apps/lib/DBD/Gofer/Policy/pedantic.pm @@ -0,0 +1,23 @@ +#line 1 "DBD/Gofer/Policy/pedantic.pm" +package DBD::Gofer::Policy::pedantic; + +# $Id: pedantic.pm 10087 2007-10-16 12:42:37Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +our $VERSION = "0.010088"; + +use base qw(DBD::Gofer::Policy::Base); + +# the 'pedantic' policy is the same as the Base policy + +1; + +#line 53 + diff --git a/apps/lib/DBD/Gofer/Policy/rush.pm b/apps/lib/DBD/Gofer/Policy/rush.pm new file mode 100644 index 0000000..5391906 --- /dev/null +++ b/apps/lib/DBD/Gofer/Policy/rush.pm @@ -0,0 +1,63 @@ +#line 1 "DBD/Gofer/Policy/rush.pm" +package DBD::Gofer::Policy::rush; + +# $Id: rush.pm 10087 2007-10-16 12:42:37Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +our $VERSION = "0.010088"; + +use base qw(DBD::Gofer::Policy::Base); + +__PACKAGE__->create_policy_subs({ + + # always use connect_cached on server + connect_method => 'connect_cached', + + # use same methods on server as is called on client + # (because code not using placeholders would bloat the sth cache) + prepare_method => '', + + # Skipping the connect check is fast, but it also skips + # fetching the remote dbh attributes! + # Make sure that your application doesn't need access to dbh attributes. + skip_connect_check => 1, + + # most code doesn't rely on sth attributes being set after prepare + skip_prepare_check => 1, + + # we're happy to use local method if that's the same as the remote + skip_default_methods => 1, + + # ping is almost meaningless for DBD::Gofer and most transports anyway + skip_ping => 1, + + # don't update dbh attributes at all + # XXX actually we currently need dbh_attribute_update for skip_default_methods to work + # and skip_default_methods is more valuable to us than the cost of dbh_attribute_update + dbh_attribute_update => 'none', # actually means 'first' currently + #dbh_attribute_list => undef, + + # we'd like to set locally_* but can't because drivers differ + + # in a rush assume metadata doesn't change + cache_tables => 1, + cache_table_info => 1, + cache_column_info => 1, + cache_primary_key_info => 1, + cache_foreign_key_info => 1, + cache_statistics_info => 1, + cache_get_info => 1, +}); + + +1; + +#line 90 + diff --git a/apps/lib/DBD/Gofer/Transport/Base.pm b/apps/lib/DBD/Gofer/Transport/Base.pm new file mode 100644 index 0000000..0970145 --- /dev/null +++ b/apps/lib/DBD/Gofer/Transport/Base.pm @@ -0,0 +1,294 @@ +#line 1 "DBD/Gofer/Transport/Base.pm" +package DBD::Gofer::Transport::Base; + +# $Id: Base.pm 14120 2010-06-07 19:52:19Z H.Merijn $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use base qw(DBI::Gofer::Transport::Base); + +our $VERSION = "0.014121"; + +__PACKAGE__->mk_accessors(qw( + trace + go_dsn + go_url + go_policy + go_timeout + go_retry_hook + go_retry_limit + go_cache + cache_hit + cache_miss + cache_store +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($class, $args) = @_; + $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store)); + $args->{keep_meta_frozen} ||= 1 if $args->{go_cache}; + #warn "args @{[ %$args ]}\n"; + return $class->SUPER::new($args); +} + + +sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 } + + +sub new_response { + my $self = shift; + return DBI::Gofer::Response->new(@_); +} + + +sub transmit_request { + my ($self, $request) = @_; + my $trace = $self->trace; + my $response; + + my ($go_cache, $request_cache_key); + if ($go_cache = $self->{go_cache}) { + $request_cache_key + = $request->{meta}{request_cache_key} + = $self->get_cache_key_for_request($request); + if ($request_cache_key) { + my $frozen_response = eval { $go_cache->get($request_cache_key) }; + if ($frozen_response) { + $self->_dump("cached response found for ".ref($request), $request) + if $trace; + $response = $self->thaw_response($frozen_response); + $self->trace_msg("transmit_request is returning a response from cache $go_cache\n") + if $trace; + ++$self->{cache_hit}; + return $response; + } + warn $@ if $@; + ++$self->{cache_miss}; + $self->trace_msg("transmit_request cache miss\n") + if $trace; + } + } + + my $to = $self->go_timeout; + my $transmit_sub = sub { + $self->trace_msg("transmit_request\n") if $trace; + local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; + + my $response = eval { + local $SIG{PIPE} = sub { + my $extra = ($! eq "Broken pipe") ? "" : " ($!)"; + die "Unable to send request: Broken pipe$extra\n"; + }; + alarm($to) if $to; + $self->transmit_request_by_transport($request); + }; + alarm(0) if $to; + + if ($@) { + return $self->transport_timedout("transmit_request", $to) + if $@ eq "TIMEOUT\n"; + return $self->new_response({ err => 1, errstr => $@ }); + } + + return $response; + }; + + $response = $self->_transmit_request_with_retries($request, $transmit_sub); + + if ($response) { + my $frozen_response = delete $response->{meta}{frozen}; + $self->_store_response_in_cache($frozen_response, $request_cache_key) + if $request_cache_key; + } + + $self->trace_msg("transmit_request is returning a response itself\n") + if $trace && $response; + + return $response unless wantarray; + return ($response, $transmit_sub); +} + + +sub _transmit_request_with_retries { + my ($self, $request, $transmit_sub) = @_; + my $response; + do { + $response = $transmit_sub->(); + } while ( $response && $self->response_needs_retransmit($request, $response) ); + return $response; +} + + +sub receive_response { + my ($self, $request, $retransmit_sub) = @_; + my $to = $self->go_timeout; + + my $receive_sub = sub { + $self->trace_msg("receive_response\n"); + local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to; + + my $response = eval { + alarm($to) if $to; + $self->receive_response_by_transport($request); + }; + alarm(0) if $to; + + if ($@) { + return $self->transport_timedout("receive_response", $to) + if $@ eq "TIMEOUT\n"; + return $self->new_response({ err => 1, errstr => $@ }); + } + return $response; + }; + + my $response; + do { + $response = $receive_sub->(); + if ($self->response_needs_retransmit($request, $response)) { + $response = $self->_transmit_request_with_retries($request, $retransmit_sub); + $response ||= $receive_sub->(); + } + } while ( $self->response_needs_retransmit($request, $response) ); + + if ($response) { + my $frozen_response = delete $response->{meta}{frozen}; + my $request_cache_key = $request->{meta}{request_cache_key}; + $self->_store_response_in_cache($frozen_response, $request_cache_key) + if $request_cache_key && $self->{go_cache}; + } + + return $response; +} + + +sub response_retry_preference { + my ($self, $request, $response) = @_; + + # give the user a chance to express a preference (or undef for default) + if (my $go_retry_hook = $self->go_retry_hook) { + my $retry = $go_retry_hook->($request, $response, $self); + $self->trace_msg(sprintf "go_retry_hook returned %s\n", + (defined $retry) ? $retry : 'undef'); + return $retry if defined $retry; + } + + # This is the main decision point. We don't retry requests that got + # as far as executing because the error is probably from the database + # (not transport) so retrying is unlikely to help. But note that any + # severe transport error occurring after execute is likely to return + # a new response object that doesn't have the execute flag set. Beware! + return 0 if $response->executed_flag_set; + + return 1 if ($response->errstr || '') =~ m/induced by DBI_GOFER_RANDOM/; + + return 1 if $request->is_idempotent; # i.e. is SELECT or ReadOnly was set + + return undef; # we couldn't make up our mind +} + + +sub response_needs_retransmit { + my ($self, $request, $response) = @_; + + my $err = $response->err + or return 0; # nothing went wrong + + my $retry = $self->response_retry_preference($request, $response); + + if (!$retry) { # false or undef + $self->trace_msg("response_needs_retransmit: response not suitable for retry\n"); + return 0; + } + + # we'd like to retry but have we retried too much already? + + my $retry_limit = $self->go_retry_limit; + if (!$retry_limit) { + $self->trace_msg("response_needs_retransmit: retries disabled (retry_limit not set)\n"); + return 0; + } + + my $request_meta = $request->meta; + my $retry_count = $request_meta->{retry_count} || 0; + if ($retry_count >= $retry_limit) { + $self->trace_msg("response_needs_retransmit: $retry_count is too many retries\n"); + # XXX should be possible to disable altering the err + $response->errstr(sprintf "%s (after %d retries by gofer)", $response->errstr, $retry_count); + return 0; + } + + # will retry now, do the admin + ++$retry_count; + $self->trace_msg("response_needs_retransmit: retry $retry_count\n"); + + # hook so response_retry_preference can defer some code execution + # until we've checked retry_count and retry_limit. + if (ref $retry eq 'CODE') { + $retry->($retry_count, $retry_limit) + and warn "should return false"; # protect future use + } + + ++$request_meta->{retry_count}; # update count for this request object + ++$self->meta->{request_retry_count}; # update cumulative transport stats + + return 1; +} + + +sub transport_timedout { + my ($self, $method, $timeout) = @_; + $timeout ||= $self->go_timeout; + return $self->new_response({ err => 1, errstr => "DBD::Gofer $method timed-out after $timeout seconds" }); +} + + +# return undef if we don't want to cache this request +# subclasses may use more specialized rules +sub get_cache_key_for_request { + my ($self, $request) = @_; + + # we only want to cache idempotent requests + # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or GOf_REQUEST_READONLY set + return undef if not $request->is_idempotent; + + # XXX would be nice to avoid the extra freeze here + my $key = $self->freeze_request($request, undef, 1); + + #use Digest::MD5; warn "get_cache_key_for_request: ".Digest::MD5::md5_base64($key)."\n"; + + return $key; +} + + +sub _store_response_in_cache { + my ($self, $frozen_response, $request_cache_key) = @_; + my $go_cache = $self->{go_cache} + or return; + + # new() ensures that enabling go_cache also enables keep_meta_frozen + warn "No meta frozen in response" if !$frozen_response; + warn "No request_cache_key" if !$request_cache_key; + + if ($frozen_response && $request_cache_key) { + $self->trace_msg("receive_response added response to cache $go_cache\n"); + eval { $go_cache->set($request_cache_key, $frozen_response) }; + warn $@ if $@; + ++$self->{cache_store}; + } +} + +1; + +__END__ + +#line 411 diff --git a/apps/lib/DBD/Gofer/Transport/corostream.pm b/apps/lib/DBD/Gofer/Transport/corostream.pm new file mode 100644 index 0000000..e0ce313 --- /dev/null +++ b/apps/lib/DBD/Gofer/Transport/corostream.pm @@ -0,0 +1,29 @@ +#line 1 "DBD/Gofer/Transport/corostream.pm" +package DBD::Gofer::Transport::corostream; + +use strict; +use warnings; + +use Carp; + +use Coro::Select; # a slow but coro-aware replacement for CORE::select (global effect!) + +use Coro; +use Coro::Handle; + +use base qw(DBD::Gofer::Transport::stream); + +# XXX ensure DBI_PUREPERL for parent doesn't pass to child +sub start_pipe_command { + local $ENV{DBI_PUREPERL} = $ENV{DBI_PUREPERL_COROCHILD}; # typically undef + my $connection = shift->SUPER::start_pipe_command(@_); + return $connection; +} + + + +1; + +__END__ + +#line 145 diff --git a/apps/lib/DBD/Gofer/Transport/null.pm b/apps/lib/DBD/Gofer/Transport/null.pm new file mode 100644 index 0000000..f2f23ee --- /dev/null +++ b/apps/lib/DBD/Gofer/Transport/null.pm @@ -0,0 +1,65 @@ +#line 1 "DBD/Gofer/Transport/null.pm" +package DBD::Gofer::Transport::null; + +# $Id: null.pm 10087 2007-10-16 12:42:37Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use base qw(DBD::Gofer::Transport::Base); + +use DBI::Gofer::Execute; + +our $VERSION = "0.010088"; + +__PACKAGE__->mk_accessors(qw( + pending_response + transmit_count +)); + +my $executor = DBI::Gofer::Execute->new(); + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests + + my $frozen_request = $self->freeze_request($request); + + # ... + # the request is magically transported over to ... ourselves + # ... + + my $response = $executor->execute_request( $self->thaw_request($frozen_request, undef, 1) ); + + # put response 'on the shelf' ready for receive_response() + $self->pending_response( $response ); + + return undef; +} + + +sub receive_response_by_transport { + my $self = shift; + + my $response = $self->pending_response; + + my $frozen_response = $self->freeze_response($response, undef, 1); + + # ... + # the response is magically transported back to ... ourselves + # ... + + return $self->thaw_response($frozen_response); +} + + +1; +__END__ + +#line 112 diff --git a/apps/lib/DBD/Gofer/Transport/pipeone.pm b/apps/lib/DBD/Gofer/Transport/pipeone.pm new file mode 100644 index 0000000..89b98a4 --- /dev/null +++ b/apps/lib/DBD/Gofer/Transport/pipeone.pm @@ -0,0 +1,212 @@ +#line 1 "DBD/Gofer/Transport/pipeone.pm" +package DBD::Gofer::Transport::pipeone; + +# $Id: pipeone.pm 10087 2007-10-16 12:42:37Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use Carp; +use Fcntl; +use IO::Select; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +use base qw(DBD::Gofer::Transport::Base); + +our $VERSION = "0.010088"; + +__PACKAGE__->mk_accessors(qw( + connection_info + go_perl +)); + + +sub new { + my ($self, $args) = @_; + $args->{go_perl} ||= do { + ($INC{"blib.pm"}) ? [ $^X, '-Mblib' ] : [ $^X ]; + }; + if (not ref $args->{go_perl}) { + # user can override the perl to be used, either with an array ref + # containing the command name and args to use, or with a string + # (ie via the DSN) in which case, to enable args to be passed, + # we split on two or more consecutive spaces (otherwise the path + # to perl couldn't contain a space itself). + $args->{go_perl} = [ split /\s{2,}/, $args->{go_perl} ]; + } + return $self->SUPER::new($args); +} + + +# nonblock($fh) puts filehandle into nonblocking mode +sub nonblock { + my $fh = shift; + my $flags = fcntl($fh, F_GETFL, 0) + or croak "Can't get flags for filehandle $fh: $!"; + fcntl($fh, F_SETFL, $flags | O_NONBLOCK) + or croak "Can't make filehandle $fh nonblocking: $!"; +} + + +sub start_pipe_command { + my ($self, $cmd) = @_; + $cmd = [ $cmd ] unless ref $cmd eq 'ARRAY'; + + # if it's important that the subprocess uses the same + # (versions of) modules as us then the caller should + # set PERL5LIB itself. + + # limit various forms of insanity, for now + local $ENV{DBI_TRACE}; # use DBI_GOFER_TRACE instead + local $ENV{DBI_AUTOPROXY}; + local $ENV{DBI_PROFILE}; + + my ($wfh, $rfh, $efh) = (gensym, gensym, gensym); + my $pid = open3($wfh, $rfh, $efh, @$cmd) + or die "error starting @$cmd: $!\n"; + if ($self->trace) { + $self->trace_msg(sprintf("Started pid $pid: @$cmd {fd: w%d r%d e%d, ppid=$$}\n", fileno $wfh, fileno $rfh, fileno $efh),0); + } + nonblock($rfh); + nonblock($efh); + my $ios = IO::Select->new($rfh, $efh); + + return { + cmd=>$cmd, + pid=>$pid, + wfh=>$wfh, rfh=>$rfh, efh=>$efh, + ios=>$ios, + }; +} + + +sub cmd_as_string { + my $self = shift; + # XXX meant to return a properly shell-escaped string suitable for system + # but its only for debugging so that can wait + my $connection_info = $self->connection_info; + return join " ", map { (m/^[-:\w]*$/) ? $_ : "'$_'" } @{$connection_info->{cmd}}; +} + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + + my $frozen_request = $self->freeze_request($request); + + my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e run_one_stdio)]; + my $info = $self->start_pipe_command($cmd); + + my $wfh = delete $info->{wfh}; + # send frozen request + local $\; + print $wfh $frozen_request + or warn "error writing to @$cmd: $!\n"; + # indicate that there's no more + close $wfh + or die "error closing pipe to @$cmd: $!\n"; + + $self->connection_info( $info ); + return; +} + + +sub read_response_from_fh { + my ($self, $fh_actions) = @_; + my $trace = $self->trace; + + my $info = $self->connection_info || die; + my ($ios) = @{$info}{qw(ios)}; + my $errors = 0; + my $complete; + + die "No handles to read response from" unless $ios->count; + + while ($ios->count) { + my @readable = $ios->can_read(); + for my $fh (@readable) { + local $_; + my $actions = $fh_actions->{$fh} || die "panic: no action for $fh"; + my $rv = sysread($fh, $_='', 1024*31); # to fit in 32KB slab + unless ($rv) { # error (undef) or end of file (0) + my $action; + unless (defined $rv) { # was an error + $self->trace_msg("error on handle $fh: $!\n") if $trace >= 4; + $action = $actions->{error} || $actions->{eof}; + ++$errors; + # XXX an error may be a permenent condition of the handle + # if so we'll loop here - not good + } + else { + $action = $actions->{eof}; + $self->trace_msg("eof on handle $fh\n") if $trace >= 4; + } + if ($action->($fh)) { + $self->trace_msg("removing $fh from handle set\n") if $trace >= 4; + $ios->remove($fh); + } + next; + } + # action returns true if the response is now complete + # (we finish all handles + $actions->{read}->($fh) && ++$complete; + } + last if $complete; + } + return $errors; +} + + +sub receive_response_by_transport { + my $self = shift; + + my $info = $self->connection_info || die; + my ($pid, $rfh, $efh, $ios, $cmd) = @{$info}{qw(pid rfh efh ios cmd)}; + + my $frozen_response; + my $stderr_msg; + + $self->read_response_from_fh( { + $efh => { + error => sub { warn "error reading response stderr: $!"; 1 }, + eof => sub { warn "eof on stderr" if 0; 1 }, + read => sub { $stderr_msg .= $_; 0 }, + }, + $rfh => { + error => sub { warn "error reading response: $!"; 1 }, + eof => sub { warn "eof on stdout" if 0; 1 }, + read => sub { $frozen_response .= $_; 0 }, + }, + }); + + waitpid $info->{pid}, 0 + or warn "waitpid: $!"; # XXX do something more useful? + + die ref($self)." command (@$cmd) failed: $stderr_msg" + if not $frozen_response; # no output on stdout at all + + # XXX need to be able to detect and deal with corruption + my $response = $self->thaw_response($frozen_response); + + if ($stderr_msg) { + # add stderr messages as warnings (for PrintWarn) + $response->add_err(0, $stderr_msg, undef, $self->trace) + # but ignore warning from old version of blib + unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; + } + + return $response; +} + + +1; + +__END__ + +#line 254 diff --git a/apps/lib/DBD/Gofer/Transport/stream.pm b/apps/lib/DBD/Gofer/Transport/stream.pm new file mode 100644 index 0000000..3826131 --- /dev/null +++ b/apps/lib/DBD/Gofer/Transport/stream.pm @@ -0,0 +1,216 @@ +#line 1 "DBD/Gofer/Transport/stream.pm" +package DBD::Gofer::Transport::stream; + +# $Id: stream.pm 14598 2010-12-21 22:53:25Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use Carp; + +use base qw(DBD::Gofer::Transport::pipeone); + +our $VERSION = "0.014599"; + +__PACKAGE__->mk_accessors(qw( + go_persist +)); + +my $persist_all = 5; +my %persist; + + +sub _connection_key { + my ($self) = @_; + return join "~", $self->go_url||"", @{ $self->go_perl || [] }; +} + + +sub _connection_get { + my ($self) = @_; + + my $persist = $self->go_persist; # = 0 can force non-caching + $persist = $persist_all if not defined $persist; + my $key = ($persist) ? $self->_connection_key : ''; + if ($persist{$key} && $self->_connection_check($persist{$key})) { + $self->trace_msg("reusing persistent connection $key\n",0) if $self->trace >= 1; + return $persist{$key}; + } + + my $connection = $self->_make_connection; + + if ($key) { + %persist = () if keys %persist > $persist_all; # XXX quick hack to limit subprocesses + $persist{$key} = $connection; + } + + return $connection; +} + + +sub _connection_check { + my ($self, $connection) = @_; + $connection ||= $self->connection_info; + my $pid = $connection->{pid}; + my $ok = (kill 0, $pid); + $self->trace_msg("_connection_check: $ok (pid $$)\n",0) if $self->trace; + return $ok; +} + + +sub _connection_kill { + my ($self) = @_; + my $connection = $self->connection_info; + my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)}; + $self->trace_msg("_connection_kill: closing write handle\n",0) if $self->trace; + # closing the write file handle should be enough, generally + close $wfh; + # in future we may want to be more aggressive + #close $rfh; close $efh; kill 15, $pid + # but deleting from the persist cache... + delete $persist{ $self->_connection_key }; + # ... and removing the connection_info should suffice + $self->connection_info( undef ); + return; +} + + +sub _make_connection { + my ($self) = @_; + + my $go_perl = $self->go_perl; + my $cmd = [ @$go_perl, qw(-MDBI::Gofer::Transport::stream -e run_stdio_hex)]; + + #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c"; + if (my $url = $self->go_url) { + die "Only 'ssh:user\@host' style url supported by this transport" + unless $url =~ s/^ssh://; + my $ssh = $url; + my $setup_env = join "||", map { "source $_ 2>/dev/null" } qw(.bash_profile .bash_login .profile); + my $setup = $setup_env.q{; exec "$@"}; + # don't use $^X on remote system by default as it's possibly wrong + $cmd->[0] = 'perl' if "@$go_perl" eq $^X; + # -x not only 'Disables X11 forwarding' but also makes connections *much* faster + unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup; + } + + $self->trace_msg("new connection: @$cmd\n",0) if $self->trace; + + # XXX add a handshake - some message from DBI::Gofer::Transport::stream that's + # sent as soon as it starts that we can wait for to report success - and soak up + # and report useful warnings etc from ssh before we get it? Increases latency though. + my $connection = $self->start_pipe_command($cmd); + return $connection; +} + + +sub transmit_request_by_transport { + my ($self, $request) = @_; + my $trace = $self->trace; + + my $connection = $self->connection_info || do { + my $con = $self->_connection_get; + $self->connection_info( $con ); + $con; + }; + + my $encoded_request = unpack("H*", $self->freeze_request($request)); + $encoded_request .= "\015\012"; + + my $wfh = $connection->{wfh}; + $self->trace_msg(sprintf("transmit_request_by_transport: to fh %s fd%d\n", $wfh, fileno($wfh)),0) + if $trace >= 4; + + # send frozen request + local $\; + $wfh->print($encoded_request) # autoflush enabled + or do { + my $err = $!; + # XXX could/should make new connection and retry + $self->_connection_kill; + die "Error sending request: $err"; + }; + $self->trace_msg("Request sent: $encoded_request\n",0) if $trace >= 4; + + return undef; # indicate no response yet (so caller calls receive_response_by_transport) +} + + +sub receive_response_by_transport { + my $self = shift; + my $trace = $self->trace; + + $self->trace_msg("receive_response_by_transport: awaiting response\n",0) if $trace >= 4; + my $connection = $self->connection_info || die; + my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)}; + + my $errno = 0; + my $encoded_response; + my $stderr_msg; + + $self->read_response_from_fh( { + $efh => { + error => sub { warn "error reading response stderr: $!"; $errno||=$!; 1 }, + eof => sub { warn "eof reading efh" if $trace >= 4; 1 }, + read => sub { $stderr_msg .= $_; 0 }, + }, + $rfh => { + error => sub { warn "error reading response: $!"; $errno||=$!; 1 }, + eof => sub { warn "eof reading rfh" if $trace >= 4; 1 }, + read => sub { $encoded_response .= $_; ($encoded_response=~s/\015\012$//) ? 1 : 0 }, + }, + }); + + # if we got no output on stdout at all then the command has + # probably exited, possibly with an error to stderr. + # Turn this situation into a reasonably useful DBI error. + if (not $encoded_response) { + my @msg; + push @msg, "error while reading response: $errno" if $errno; + if ($stderr_msg) { + chomp $stderr_msg; + push @msg, sprintf "error reported by \"%s\" (pid %d%s): %s", + $self->cmd_as_string, + $pid, ((kill 0, $pid) ? "" : ", exited"), + $stderr_msg; + } + die join(", ", "No response received", @msg)."\n"; + } + + $self->trace_msg("Response received: $encoded_response\n",0) + if $trace >= 4; + + $self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0) + if $stderr_msg && $trace; + + my $frozen_response = pack("H*", $encoded_response); + + # XXX need to be able to detect and deal with corruption + my $response = $self->thaw_response($frozen_response); + + if ($stderr_msg) { + # add stderr messages as warnings (for PrintWarn) + $response->add_err(0, $stderr_msg, undef, $trace) + # but ignore warning from old version of blib + unless $stderr_msg =~ /^Using .*blib/ && "@$cmd" =~ /-Mblib/; + } + + return $response; +} + +sub transport_timedout { + my $self = shift; + $self->_connection_kill; + return $self->SUPER::transport_timedout(@_); +} + +1; + +__END__ + +#line 293 diff --git a/apps/lib/DBD/NullP.pm b/apps/lib/DBD/NullP.pm new file mode 100644 index 0000000..40917bf --- /dev/null +++ b/apps/lib/DBD/NullP.pm @@ -0,0 +1,207 @@ +#line 1 "DBD/NullP.pm" +use strict; +{ + package DBD::NullP; + + require DBI; + require Carp; + + our @EXPORT = qw(); # Do NOT @EXPORT anything. + our $VERSION = "12.014715"; + +# $Id: NullP.pm 14714 2011-02-22 17:27:07Z Tim $ +# +# Copyright (c) 1994-2007 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + our $drh = undef; # holds driver handle once initialised + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'NullP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Null Perl stub by Tim Bunce', + }, [ qw'example implementors private data']); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::NullP::dr; # ====== DRIVER ====== + our $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my $dbh = shift->SUPER::connect(@_) + or return; + $dbh->STORE(Active => 1); + $dbh; + } + + + sub DESTROY { undef } +} + + +{ package DBD::NullP::db; # ====== DATABASE ====== + our $imp_data_size = 0; + use strict; + use Carp qw(croak); + + # Added get_info to support tests in 10examp.t + sub get_info { + my ($dbh, $type) = @_; + + if ($type == 29) { # identifier quote + return '"'; + } + return; + } + + # Added table_info to support tests in 10examp.t + sub table_info { + my ($dbh, $catalog, $schema, $table, $type) = @_; + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => 'tables', + }); + if (defined($type) && $type eq '%' && # special case for tables('','','','%') + grep {defined($_) && $_ eq ''} ($catalog, $schema, $table)) { + $outer->{dbd_nullp_data} = [[undef, undef, undef, 'TABLE', undef], + [undef, undef, undef, 'VIEW', undef], + [undef, undef, undef, 'ALIAS', undef]]; + } elsif (defined($catalog) && $catalog eq '%' && # special case for tables('%','','') + grep {defined($_) && $_ eq ''} ($schema, $table)) { + $outer->{dbd_nullp_data} = [['catalog1', undef, undef, undef, undef], + ['catalog2', undef, undef, undef, undef]]; + } else { + $outer->{dbd_nullp_data} = [['catalog', 'schema', 'table1', 'TABLE']]; + $outer->{dbd_nullp_data} = [['catalog', 'schema', 'table2', 'TABLE']]; + $outer->{dbd_nullp_data} = [['catalog', 'schema', 'table3', 'TABLE']]; + } + $outer->STORE(NUM_OF_FIELDS => 5); + $sth->STORE(Active => 1); + return $outer; + } + + sub prepare { + my ($dbh, $statement)= @_; + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + }); + + return $outer; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + Carp::croak("Can't disable AutoCommit") unless $value; + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } elsif ($attrib eq 'nullp_set_err') { + # a fake attribute to produce a test case where STORE issues a warning + $dbh->set_err($value, $value); + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub ping { 1 } + + sub disconnect { + shift->STORE(Active => 0); + } + +} + + +{ package DBD::NullP::st; # ====== STATEMENT ====== + our $imp_data_size = 0; + use strict; + + sub bind_param { + my ($sth, $param, $value, $attr) = @_; + $sth->{ParamValues}{$param} = $value; + $sth->{ParamAttr}{$param} = $attr + if defined $attr; # attr is sticky if not explicitly set + return 1; + } + + sub execute { + my $sth = shift; + $sth->bind_param($_, $_[$_-1]) for (1..@_); + if ($sth->{Statement} =~ m/^ \s* SELECT \s+/xmsi) { + $sth->STORE(NUM_OF_FIELDS => 1); + $sth->{NAME} = [ "fieldname" ]; + # just for the sake of returning something, we return the params + my $params = $sth->{ParamValues} || {}; + $sth->{dbd_nullp_data} = [ @{$params}{ sort keys %$params } ]; + $sth->STORE(Active => 1); + } + # force a sleep - handy for testing + elsif ($sth->{Statement} =~ m/^ \s* SLEEP \s+ (\S+) /xmsi) { + my $secs = $1; + if (eval { require Time::HiRes; defined &Time::HiRes::sleep }) { + Time::HiRes::sleep($secs); + } + else { + sleep $secs; + } + } + # force an error - handy for testing + elsif ($sth->{Statement} =~ m/^ \s* ERROR \s+ (\d+) \s* (.*) /xmsi) { + return $sth->set_err($1, $2); + } + # anything else is silently ignored, successfully + 1; + } + + sub fetchrow_arrayref { + my $sth = shift; + my $data = shift @{$sth->{dbd_nullp_data}}; + if (!$data || !@$data) { + $sth->finish; # no more data so finish + return undef; + } + return $sth->_set_fbav($data); + } + *fetch = \&fetchrow_arrayref; # alias + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } + +} + +1; diff --git a/lib/DBD/PgPP.pm b/apps/lib/DBD/PgPP.pm similarity index 81% rename from lib/DBD/PgPP.pm rename to apps/lib/DBD/PgPP.pm index 16f1eb5..8d4219b 100644 --- a/lib/DBD/PgPP.pm +++ b/apps/lib/DBD/PgPP.pm @@ -1,3 +1,4 @@ +#line 1 "DBD/PgPP.pm" package DBD::PgPP; use strict; @@ -6,19 +7,7 @@ use Carp (); use IO::Socket (); use Digest::MD5 (); -=head1 NAME - -DBD::PgPP - Pure Perl PostgreSQL driver for the DBI - -=head1 SYNOPSIS - - use DBI; - - my $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', ''); - - # See the DBI module documentation for full details - -=cut +#line 22 our $VERSION = '0.08'; my $BUFFER_LEN = 1500; @@ -1409,260 +1398,4 @@ sub is_empty { 1 } 1; __END__ -=head1 DESCRIPTION - -DBD::PgPP is a pure-Perl client interface for the PostgreSQL database. This -module implements the network protocol that allows a client to communicate -with a PostgreSQL server, so you don't need an external PostgreSQL client -library like B for it to work. That means this module enables you to -connect to PostgreSQL server from platforms where there's no PostgreSQL -port, or where installing PostgreSQL is prohibitively hard. - -=head1 MODULE DOCUMENTATION - -This documentation describes driver specific behavior and restrictions; it -does not attempt to describe everything you might need to use DBD::PgPP. In -particular, users are advised to be familiar with the DBI documentation. - -=head1 THE DBI CLASS - -=head2 DBI Class Methods - -=over 4 - -=item B - -At a minimum, you need to use code like this to connect to the database: - - $dbh = DBI->connect('dbi:PgPP:dbname=$dbname', '', ''); - -This connects to the database $dbname on localhost without any user -authentication. This may well be sufficient for some PostgreSQL -installations. - -The following connect statement shows all possible parameters: - - $dbh = DBI->connect("dbi:PgPP:dbname=$dbname", $username, $password); - - $dbh = DBI->connect("dbi:PgPP:dbname=$dbname;host=$host;port=$port", - $username, $password); - - $dbh = DBI->connect("dbi:PgPP:dbname=$dbname;path=$path;port=$port", - $username, $password); - - parameter | hard coded default - ----------+------------------- - dbname | current userid - host | localhost - port | 5432 - path | /tmp - debug | undef - -If a host is specified, the postmaster on this host needs to be started with -the C<-i> option (TCP/IP socket). - -For authentication with username and password appropriate entries have to be -made in pg_hba.conf. Please refer to the PostgreSQL documentation for -pg_hba.conf and pg_passwd for the various types of authentication. - -=back - -=head1 DATABASE-HANDLE METHODS - -=over 4 - -=item C - - $rv = $dbh->last_insert_id($catalog, $schema, $table, $field); - $rv = $dbh->last_insert_id($catalog, $schema, $table, $field, \%attr); - -Attempts to return the id of the last value to be inserted into a table. -Since PostgreSQL uses the C type to implement such things, this -method finds a sequence's value using the C PostgreSQL function. -This will fail if the sequence has not yet been used in the current database -connection. - -DBD::PgPP ignores the $catalog and $field arguments are ignored in all -cases, but they're required by DBI itself. - -If you don't know the name of the applicable sequence for the table, you can -simply provide a table name (optionally qualified by a schema name), and -DBD::PgPP will attempt to work out which sequence will contain the correct -value: - - $dbh->do(q{CREATE TABLE t (id serial primary key, s text not null)}); - my $sth = $dbh->prepare('INSERT INTO t (s) VALUES (?)'); - for my $value (@values) { - $sth->execute($value); - my $id = $dbh->last_insert_id(undef, undef, 't', undef); - print "Inserted $id: $value\n"; - } - -In most situations, that is the simplest approach. However, it requires the -table to have at least one column which is non-null and unique, and uses a -sequence as its default value. (If there is more than one such column, the -primary key is used.) - -If those requirements aren't met in your situation, you can alternatively -specify the sequence name directly: - - $dbh->do(q{CREATE SEQUENCE t_id_seq START 1}); - $dbh->do(q{CREATE TABLE t ( - id int not null unique DEFAULT nextval('t_id_seq'), - s text not null)}); - my $sth = $dbh->prepare('INSERT INTO t (s) VALUES (?)'); - for my $value (@values) { - $sth->execute($value); - my $id = $dbh->last_insert_id(undef, undef, undef, undef, { - sequence => 't_id_seq', - }); - print "Inserted $id: $value\n"; - } - -If you adopt the simpler approach, note that DBD::PgPP will have to issue -some queries to look things up in the system tables. DBD::PgPP will then -cache the appropriate sequence name for subsequent calls. Should you need -to disable this caching for some reason, you can supply a true value for the -attribute C: - - my $id = $dbh->last_insert_id(undef, undef, $table, undef, { - pgpp_cache => 0, - }); - -Please keep in mind that C is far from foolproof, so make -your program uses it carefully. Specifically, C should be -used only immediately after an insert to the table in question, and that -insert must not specify a value for the applicable column. - -=back - -=head1 OTHER FUNCTIONS - -As of DBD::PgPP 0.06, you can use the following functions to determine the -version of the server to which a database handle is connected. Note the -unusual calling convention; it may be changed in the future. - -=over 4 - -=item C - -The server's version identification string, as returned by the standard -C function available in PostgreSQL 7.2 and above. If the server -doesn't support that function, returns an empty string. - -=item C - -The server's version string, as parsed out of the return value of the -standard C function available in PostgreSQL 7.2 and above. For -example, returns the string C<8.3.5> if the server is release 8.3.5. If the -server doesn't support C, returns the string C<0.0.0>. - -=item C - -A number representing the server's version number, as parsed out of the -return value of the standard C function available in PostgreSQL -7.2 and above. For example, returns 80305 if the server is release 8.3.5. -If the server doesn't support C, returns zero. - -=back - -=head1 BUGS, LIMITATIONS, AND TODO - -=over 4 - -=item * - -The C DSN parameter is incorrectly global: if you enable it for one -database handle, it gets enabled for all database handles in the current -Perl interpreter. It should probably be removed entirely in favour of DBI's -built-in and powerful tracing mechanism, but that's too hard to do in the -current architecture. - -=item * - -No support for Kerberos or SCM Credential authentication; and there's no -support for crypt authentication on some platforms. - -=item * - -Can't use SSL for encrypted connections. - -=item * - -Using multiple semicolon-separated queries in a single statement will cause -DBD::PgPP to fail in a way that requires you to reconnect to the server. - -=item * - -No support for COPY, or LISTEN notifications, or for cancelling in-progress -queries. (There's also no support for the "explicit function call" part of -the protocol, but there's nothing you can do that way that isn't more easily -achieved by writing SQL to call the function.) - -=item * - -There's currently no way to get informed about any warnings PostgreSQL may -issue for your queries. - -=item * - -No support for BLOB data types or long objects. - -=item * - -Currently assumes that the Perl code and the database use the same encoding -for text; probably also assumes that the encoding uses eight bits per -character. Future versions are expected to support UTF-8-encoded Unicode -(in a way that's compatible with Perl's own string encodings). - -=item * - -You can't use any data type that (like bytea) requires C<< $dbh->quote >> to -use any syntax other than standard string literals. Using booleans and -numbers works to the extent that PostgreSQL supports string-ish syntax for -them, but that varies from one version to another. The only reliable way to -solve this and still support PostgreSQL 7.3 and below is to use the DBI -C mechanism and say which type you want; but typed bind_param -ignores the type at the moment. - -=back - -=head1 DEPENDENCIES - -This module requires Perl 5.8 or higher. (If you want it to work under -earlier Perl versions, patches are welcome.) - -The only module used (other than those which ship with supported Perl -versions) is L. - -=head1 SEE ALSO - -L, L, -L - -=head1 AUTHOR - -Hiroyuki OYAMA Eoyama@module.jpE - -=head1 COPYRIGHT AND LICENCE - -Copyright (C) 2004 Hiroyuki OYAMA. All rights reserved. -Copyright (C) 2004, 2005, 2009, 2010 Aaron Crane. All rights reserved. - -DBD::PgPP is free software; you can redistribute it and/or modify it under -the terms of Perl itself, that is to say, under the terms of either: - -=over 4 - -=item * - -The GNU General Public License as published by the Free Software Foundation; -either version 2, or (at your option) any later version, or - -=item * - -The "Artistic License" which comes with Perl. - -=back - -=cut +#line 1669 diff --git a/apps/lib/DBD/SQLite.pm b/apps/lib/DBD/SQLite.pm new file mode 100644 index 0000000..b33f384 --- /dev/null +++ b/apps/lib/DBD/SQLite.pm @@ -0,0 +1,1004 @@ +#line 1 "DBD/SQLite.pm" +package DBD::SQLite; + +use 5.006; +use strict; +use DBI 1.57 (); +use DynaLoader (); + +our $VERSION = '1.62'; +our @ISA = 'DynaLoader'; + +# sqlite_version cache (set in the XS bootstrap) +our ($sqlite_version, $sqlite_version_number); + +# not sure if we still need these... +our ($err, $errstr); + +__PACKAGE__->bootstrap($VERSION); + +# New or old API? +use constant NEWAPI => ($DBI::VERSION >= 1.608); + +# global registry of collation functions, initialized with 2 builtins +our %COLLATION; +tie %COLLATION, 'DBD::SQLite::_WriteOnceHash'; +$COLLATION{perl} = sub { $_[0] cmp $_[1] }; +$COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] }; + +our $drh; +my $methods_are_installed = 0; + +sub driver { + return $drh if $drh; + + if (!$methods_are_installed && DBD::SQLite::NEWAPI ) { + DBI->setup_driver('DBD::SQLite'); + + DBD::SQLite::db->install_method('sqlite_last_insert_rowid'); + DBD::SQLite::db->install_method('sqlite_busy_timeout'); + DBD::SQLite::db->install_method('sqlite_create_function'); + DBD::SQLite::db->install_method('sqlite_create_aggregate'); + DBD::SQLite::db->install_method('sqlite_create_collation'); + DBD::SQLite::db->install_method('sqlite_collation_needed'); + DBD::SQLite::db->install_method('sqlite_progress_handler'); + DBD::SQLite::db->install_method('sqlite_commit_hook'); + DBD::SQLite::db->install_method('sqlite_rollback_hook'); + DBD::SQLite::db->install_method('sqlite_update_hook'); + DBD::SQLite::db->install_method('sqlite_set_authorizer'); + DBD::SQLite::db->install_method('sqlite_backup_from_file'); + DBD::SQLite::db->install_method('sqlite_backup_to_file'); + DBD::SQLite::db->install_method('sqlite_backup_from_dbh'); + DBD::SQLite::db->install_method('sqlite_backup_to_dbh'); + DBD::SQLite::db->install_method('sqlite_enable_load_extension'); + DBD::SQLite::db->install_method('sqlite_load_extension'); + DBD::SQLite::db->install_method('sqlite_register_fts3_perl_tokenizer'); + DBD::SQLite::db->install_method('sqlite_trace', { O => 0x0004 }); + DBD::SQLite::db->install_method('sqlite_profile', { O => 0x0004 }); + DBD::SQLite::db->install_method('sqlite_table_column_metadata', { O => 0x0004 }); + DBD::SQLite::db->install_method('sqlite_db_filename', { O => 0x0004 }); + DBD::SQLite::db->install_method('sqlite_db_status', { O => 0x0004 }); + DBD::SQLite::st->install_method('sqlite_st_status', { O => 0x0004 }); + DBD::SQLite::db->install_method('sqlite_create_module'); + DBD::SQLite::db->install_method('sqlite_limit'); + DBD::SQLite::db->install_method('sqlite_db_config'); + + $methods_are_installed++; + } + + $drh = DBI::_new_drh( "$_[0]::dr", { + Name => 'SQLite', + Version => $VERSION, + Attribution => 'DBD::SQLite by Matt Sergeant et al', + } ); + + return $drh; +} + +sub CLONE { + undef $drh; +} + + +package # hide from PAUSE + DBD::SQLite::dr; + +sub connect { + my ($drh, $dbname, $user, $auth, $attr) = @_; + + # Default PrintWarn to the value of $^W + # unless ( defined $attr->{PrintWarn} ) { + # $attr->{PrintWarn} = $^W ? 1 : 0; + # } + + my $dbh = DBI::_new_dbh( $drh, { + Name => $dbname, + } ); + + my $real = $dbname; + if ( $dbname =~ /=/ ) { + foreach my $attrib ( split(/;/, $dbname) ) { + my ($key, $value) = split(/=/, $attrib, 2); + if ( $key =~ /^(?:db(?:name)?|database)$/ ) { + $real = $value; + } elsif ( $key eq 'uri' ) { + $real = $value; + $attr->{sqlite_open_flags} |= DBD::SQLite::OPEN_URI(); + } else { + $attr->{$key} = $value; + } + } + } + + if (my $flags = $attr->{sqlite_open_flags}) { + unless ($flags & (DBD::SQLite::OPEN_READONLY() | DBD::SQLite::OPEN_READWRITE())) { + $attr->{sqlite_open_flags} |= DBD::SQLite::OPEN_READWRITE() | DBD::SQLite::OPEN_CREATE(); + } + } + + # To avoid unicode and long file name problems on Windows, + # convert to the shortname if the file (or parent directory) exists. + if ( $^O =~ /MSWin32/ and $real ne ':memory:' and $real ne '' and $real !~ /^file:/ and !-f $real ) { + require File::Basename; + my ($file, $dir, $suffix) = File::Basename::fileparse($real); + # We are creating a new file. + # Does the directory it's in at least exist? + if ( -d $dir ) { + require Win32; + $real = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix; + } else { + # SQLite can't do mkpath anyway. + # So let it go through as it and fail. + } + } + + # Hand off to the actual login function + DBD::SQLite::db::_login($dbh, $real, $user, $auth, $attr) or return undef; + + # Register the on-demand collation installer, REGEXP function and + # perl tokenizer + if ( DBD::SQLite::NEWAPI ) { + $dbh->sqlite_collation_needed( \&install_collation ); + $dbh->sqlite_create_function( "REGEXP", 2, \®exp ); + $dbh->sqlite_register_fts3_perl_tokenizer(); + } else { + $dbh->func( \&install_collation, "collation_needed" ); + $dbh->func( "REGEXP", 2, \®exp, "create_function" ); + $dbh->func( "register_fts3_perl_tokenizer" ); + } + + # HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings + # in DBD::SQLite we set Warn to false if PrintWarn is false. + + # NOTE: According to the explanation by timbunce, + # "Warn is meant to report on bad practices or problems with + # the DBI itself (hence always on by default), while PrintWarn + # is meant to report warnings coming from the database." + # That is, if you want to disable an ineffective rollback warning + # etc (due to bad practices), you should turn off Warn, + # and to silence other warnings, turn off PrintWarn. + # Warn and PrintWarn are independent, and turning off PrintWarn + # does not silence those warnings that should be controlled by + # Warn. + + # unless ( $attr->{PrintWarn} ) { + # $attr->{Warn} = 0; + # } + + return $dbh; +} + +sub install_collation { + my $dbh = shift; + my $name = shift; + my $collation = $DBD::SQLite::COLLATION{$name}; + unless ($collation) { + warn "Can't install unknown collation: $name" if $dbh->{PrintWarn}; + return; + } + if ( DBD::SQLite::NEWAPI ) { + $dbh->sqlite_create_collation( $name => $collation ); + } else { + $dbh->func( $name => $collation, "create_collation" ); + } +} + +# default implementation for sqlite 'REGEXP' infix operator. +# Note : args are reversed, i.e. "a REGEXP b" calls REGEXP(b, a) +# (see https://www.sqlite.org/vtab.html#xfindfunction) +sub regexp { + use locale; + return if !defined $_[0] || !defined $_[1]; + return scalar($_[1] =~ $_[0]); +} + +package # hide from PAUSE + DBD::SQLite::db; + +use DBI qw/:sql_types/; + +sub prepare { + my $dbh = shift; + my $sql = shift; + $sql = '' unless defined $sql; + + my $sth = DBI::_new_sth( $dbh, { + Statement => $sql, + } ); + + DBD::SQLite::st::_prepare($sth, $sql, @_) or return undef; + + return $sth; +} + +sub do { + my ($dbh, $statement, $attr, @bind_values) = @_; + + # shortcut + my $allow_multiple_statements = $dbh->FETCH('sqlite_allow_multiple_statements'); + if (defined $statement && !defined $attr && !@bind_values) { + # _do() (i.e. sqlite3_exec()) runs semicolon-separate SQL + # statements, which is handy but insecure sometimes. + # Use this only when it's safe or explicitly allowed. + if (index($statement, ';') == -1 or $allow_multiple_statements) { + return DBD::SQLite::db::_do($dbh, $statement); + } + } + + my @copy = @{[@bind_values]}; + my $rows = 0; + + while ($statement) { + my $sth = $dbh->prepare($statement, $attr) or return undef; + $sth->execute(splice @copy, 0, $sth->{NUM_OF_PARAMS}) or return undef; + $rows += $sth->rows; + # XXX: not sure why but $dbh->{sqlite...} wouldn't work here + last unless $allow_multiple_statements; + $statement = $sth->{sqlite_unprepared_statements}; + } + + # always return true if no error + return ($rows == 0) ? "0E0" : $rows; +} + +sub ping { + my $dbh = shift; + + # $file may be undef (ie. in-memory/temporary database) + my $file = DBD::SQLite::NEWAPI ? $dbh->sqlite_db_filename + : $dbh->func("db_filename"); + + return 0 if $file && !-f $file; + return $dbh->FETCH('Active') ? 1 : 0; +} + +sub get_info { + my ($dbh, $info_type) = @_; + + require DBD::SQLite::GetInfo; + my $v = $DBD::SQLite::GetInfo::info{int($info_type)}; + $v = $v->($dbh) if ref $v eq 'CODE'; + return $v; +} + +sub _attached_database_list { + my $dbh = shift; + my @attached; + + my $sth_databases = $dbh->prepare( 'PRAGMA database_list' ) or return; + $sth_databases->execute or return; + while ( my $db_info = $sth_databases->fetchrow_hashref ) { + push @attached, $db_info->{name} if $db_info->{seq} >= 2; + } + return @attached; +} + +# SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables +# Based on DBD::Oracle's +# See also http://www.ch-werner.de/sqliteodbc/html/sqlite3odbc_8c.html#a213 +sub table_info { + my ($dbh, $cat_val, $sch_val, $tbl_val, $typ_val, $attr) = @_; + + my @where = (); + my $sql; + if ( defined($cat_val) && $cat_val eq '%' + && defined($sch_val) && $sch_val eq '' + && defined($tbl_val) && $tbl_val eq '') { # Rule 19a + $sql = <<'END_SQL'; +SELECT NULL TABLE_CAT + , NULL TABLE_SCHEM + , NULL TABLE_NAME + , NULL TABLE_TYPE + , NULL REMARKS +END_SQL + } + elsif ( defined($cat_val) && $cat_val eq '' + && defined($sch_val) && $sch_val eq '%' + && defined($tbl_val) && $tbl_val eq '') { # Rule 19b + $sql = <<'END_SQL'; +SELECT NULL TABLE_CAT + , t.tn TABLE_SCHEM + , NULL TABLE_NAME + , NULL TABLE_TYPE + , NULL REMARKS +FROM ( + SELECT 'main' tn + UNION SELECT 'temp' tn +END_SQL + for my $db_name (_attached_database_list($dbh)) { + $sql .= " UNION SELECT '$db_name' tn\n"; + } + $sql .= ") t\n"; + } + elsif ( defined($cat_val) && $cat_val eq '' + && defined($sch_val) && $sch_val eq '' + && defined($tbl_val) && $tbl_val eq '' + && defined($typ_val) && $typ_val eq '%') { # Rule 19c + $sql = <<'END_SQL'; +SELECT NULL TABLE_CAT + , NULL TABLE_SCHEM + , NULL TABLE_NAME + , t.tt TABLE_TYPE + , NULL REMARKS +FROM ( + SELECT 'TABLE' tt UNION + SELECT 'VIEW' tt UNION + SELECT 'LOCAL TEMPORARY' tt UNION + SELECT 'SYSTEM TABLE' tt +) t +ORDER BY TABLE_TYPE +END_SQL + } + else { + $sql = <<'END_SQL'; +SELECT * +FROM +( +SELECT NULL TABLE_CAT + , TABLE_SCHEM + , tbl_name TABLE_NAME + , TABLE_TYPE + , NULL REMARKS + , sql sqlite_sql +FROM ( + SELECT 'main' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql + FROM sqlite_master +UNION ALL + SELECT 'temp' TABLE_SCHEM, tbl_name, 'LOCAL TEMPORARY' TABLE_TYPE, sql + FROM sqlite_temp_master +END_SQL + + for my $db_name (_attached_database_list($dbh)) { + $sql .= <<"END_SQL"; +UNION ALL + SELECT '$db_name' TABLE_SCHEM, tbl_name, upper(type) TABLE_TYPE, sql + FROM "$db_name".sqlite_master +END_SQL + } + + $sql .= <<'END_SQL'; +UNION ALL + SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql +UNION ALL + SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name, 'SYSTEM TABLE' TABLE_TYPE, NULL sql +) +) +END_SQL + $attr = {} unless ref $attr eq 'HASH'; + my $escape = defined $attr->{Escape} ? " ESCAPE '$attr->{Escape}'" : ''; + if ( defined $sch_val ) { + push @where, "TABLE_SCHEM LIKE '$sch_val'$escape"; + } + if ( defined $tbl_val ) { + push @where, "TABLE_NAME LIKE '$tbl_val'$escape"; + } + if ( defined $typ_val ) { + my $table_type_list; + $typ_val =~ s/^\s+//; + $typ_val =~ s/\s+$//; + my @ttype_list = split (/\s*,\s*/, $typ_val); + foreach my $table_type (@ttype_list) { + if ($table_type !~ /^'.*'$/) { + $table_type = "'" . $table_type . "'"; + } + } + $table_type_list = join(', ', @ttype_list); + push @where, "TABLE_TYPE IN (\U$table_type_list)" if $table_type_list; + } + $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; + $sql .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n"; + } + my $sth = $dbh->prepare($sql) or return undef; + $sth->execute or return undef; + $sth; +} + +sub primary_key_info { + my ($dbh, $catalog, $schema, $table, $attr) = @_; + + my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}); + + my @pk_info; + for my $database (@$databases) { + my $dbname = $database->{name}; + next if defined $schema && $schema ne '%' && $schema ne $dbname; + + my $quoted_dbname = $dbh->quote_identifier($dbname); + + my $master_table = + ($dbname eq 'main') ? 'sqlite_master' : + ($dbname eq 'temp') ? 'sqlite_temp_master' : + $quoted_dbname.'.sqlite_master'; + + my $sth = $dbh->prepare("SELECT name, sql FROM $master_table WHERE type = ?") or return; + $sth->execute("table") or return; + while(my $row = $sth->fetchrow_hashref) { + my $tbname = $row->{name}; + next if defined $table && $table ne '%' && $table ne $tbname; + + my $quoted_tbname = $dbh->quote_identifier($tbname); + my $t_sth = $dbh->prepare("PRAGMA $quoted_dbname.table_info($quoted_tbname)") or return; + $t_sth->execute or return; + my @pk; + while(my $col = $t_sth->fetchrow_hashref) { + push @pk, $col->{name} if $col->{pk}; + } + + # If there're multiple primary key columns, we need to + # find their order from one of the auto-generated unique + # indices (note that single column integer primary key + # doesn't create an index). + if (@pk > 1 and $row->{sql} =~ /\bPRIMARY\s+KEY\s*\(\s* + ( + (?: + ( + [a-z_][a-z0-9_]* + | (["'`])(?:\3\3|(?!\3).)+?\3(?!\3) + | \[[^\]]+\] + ) + \s*,\s* + )+ + ( + [a-z_][a-z0-9_]* + | (["'`])(?:\5\5|(?!\5).)+?\5(?!\5) + | \[[^\]]+\] + ) + ) + \s*\)/six) { + my $pk_sql = $1; + @pk = (); + while($pk_sql =~ / + ( + [a-z_][a-z0-9_]* + | (["'`])(?:\2\2|(?!\2).)+?\2(?!\2) + | \[([^\]]+)\] + ) + (?:\s*,\s*|$) + /sixg) { + my($col, $quote, $brack) = ($1, $2, $3); + if ( defined $quote ) { + # Dequote "'` + $col = substr $col, 1, -1; + $col =~ s/$quote$quote/$quote/g; + } elsif ( defined $brack ) { + # Dequote [] + $col = $brack; + } + push @pk, $col; + } + } + + my $key_name = $row->{sql} =~ /\bCONSTRAINT\s+(\S+|"[^"]+")\s+PRIMARY\s+KEY\s*\(/i ? $1 : 'PRIMARY KEY'; + my $key_seq = 0; + foreach my $pk_field (@pk) { + push @pk_info, { + TABLE_SCHEM => $dbname, + TABLE_NAME => $tbname, + COLUMN_NAME => $pk_field, + KEY_SEQ => ++$key_seq, + PK_NAME => $key_name, + }; + } + } + } + + my $sponge = DBI->connect("DBI:Sponge:", '','') + or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); + my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME); + my $sth = $sponge->prepare( "primary_key_info", { + rows => [ map { [ @{$_}{@names} ] } @pk_info ], + NUM_OF_FIELDS => scalar @names, + NAME => \@names, + }) or return $dbh->DBI::set_err( + $sponge->err, + $sponge->errstr, + ); + return $sth; +} + + +our %DBI_code_for_rule = ( # from DBI doc; curiously, they are not exported + # by the DBI module. + # codes for update/delete constraints + 'CASCADE' => 0, + 'RESTRICT' => 1, + 'SET NULL' => 2, + 'NO ACTION' => 3, + 'SET DEFAULT' => 4, + + # codes for deferrability + 'INITIALLY DEFERRED' => 5, + 'INITIALLY IMMEDIATE' => 6, + 'NOT DEFERRABLE' => 7, + ); + + +my @FOREIGN_KEY_INFO_ODBC = ( + 'PKTABLE_CAT', # The primary (unique) key table catalog identifier. + 'PKTABLE_SCHEM', # The primary (unique) key table schema identifier. + 'PKTABLE_NAME', # The primary (unique) key table identifier. + 'PKCOLUMN_NAME', # The primary (unique) key column identifier. + 'FKTABLE_CAT', # The foreign key table catalog identifier. + 'FKTABLE_SCHEM', # The foreign key table schema identifier. + 'FKTABLE_NAME', # The foreign key table identifier. + 'FKCOLUMN_NAME', # The foreign key column identifier. + 'KEY_SEQ', # The column sequence number (starting with 1). + 'UPDATE_RULE', # The referential action for the UPDATE rule. + 'DELETE_RULE', # The referential action for the DELETE rule. + 'FK_NAME', # The foreign key name. + 'PK_NAME', # The primary (unique) key name. + 'DEFERRABILITY', # The deferrability of the foreign key constraint. + 'UNIQUE_OR_PRIMARY', # qualifies the key referenced by the foreign key +); + +# Column names below are not used, but listed just for completeness's sake. +# Maybe we could add an option so that the user can choose which field +# names will be returned; the DBI spec is not very clear about ODBC vs. CLI. +my @FOREIGN_KEY_INFO_SQL_CLI = qw( + UK_TABLE_CAT + UK_TABLE_SCHEM + UK_TABLE_NAME + UK_COLUMN_NAME + FK_TABLE_CAT + FK_TABLE_SCHEM + FK_TABLE_NAME + FK_COLUMN_NAME + ORDINAL_POSITION + UPDATE_RULE + DELETE_RULE + FK_NAME + UK_NAME + DEFERABILITY + UNIQUE_OR_PRIMARY + ); + +my $DEFERRABLE_RE = qr/ + (?:(?: + on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action) + | + match \s* (?:\S+|".+?(?selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return; + + my @fk_info; + my %table_info; + for my $database (@$databases) { + my $dbname = $database->{name}; + next if defined $fk_schema && $fk_schema ne '%' && $fk_schema ne $dbname; + + my $quoted_dbname = $dbh->quote_identifier($dbname); + my $master_table = + ($dbname eq 'main') ? 'sqlite_master' : + ($dbname eq 'temp') ? 'sqlite_temp_master' : + $quoted_dbname.'.sqlite_master'; + + my $tables = $dbh->selectall_arrayref("SELECT name, sql FROM $master_table WHERE type = ?", undef, "table") or return; + for my $table (@$tables) { + my $tbname = $table->[0]; + my $ddl = $table->[1]; + my (@rels, %relid2rels); + next if defined $fk_table && $fk_table ne '%' && $fk_table ne $tbname; + + my $quoted_tbname = $dbh->quote_identifier($tbname); + my $sth = $dbh->prepare("PRAGMA $quoted_dbname.foreign_key_list($quoted_tbname)") or return; + $sth->execute or return; + while(my $row = $sth->fetchrow_hashref) { + next if defined $pk_table && $pk_table ne '%' && $pk_table ne $row->{table}; + + unless ($table_info{$row->{table}}) { + my $quoted_tb = $dbh->quote_identifier($row->{table}); + for my $db (@$databases) { + my $quoted_db = $dbh->quote_identifier($db->{name}); + my $t_sth = $dbh->prepare("PRAGMA $quoted_db.table_info($quoted_tb)") or return; + $t_sth->execute or return; + my $cols = {}; + while(my $r = $t_sth->fetchrow_hashref) { + $cols->{$r->{name}} = $r->{pk}; + } + if (keys %$cols) { + $table_info{$row->{table}} = { + schema => $db->{name}, + columns => $cols, + }; + last; + } + } + } + + next if defined $pk_schema && $pk_schema ne '%' && $pk_schema ne $table_info{$row->{table}}{schema}; + + # cribbed from DBIx::Class::Schema::Loader::DBI::SQLite + my $rel = $rels[ $row->{id} ] ||= { + local_columns => [], + remote_columns => undef, + remote_table => $row->{table}, + }; + push @{ $rel->{local_columns} }, $row->{from}; + push @{ $rel->{remote_columns} }, $row->{to} + if defined $row->{to}; + + my $fk_row = { + PKTABLE_CAT => undef, + PKTABLE_SCHEM => $table_info{$row->{table}}{schema}, + PKTABLE_NAME => $row->{table}, + PKCOLUMN_NAME => $row->{to}, + FKTABLE_CAT => undef, + FKTABLE_SCHEM => $dbname, + FKTABLE_NAME => $tbname, + FKCOLUMN_NAME => $row->{from}, + KEY_SEQ => $row->{seq} + 1, + UPDATE_RULE => $DBI_code_for_rule{$row->{on_update}}, + DELETE_RULE => $DBI_code_for_rule{$row->{on_delete}}, + FK_NAME => undef, + PK_NAME => undef, + DEFERRABILITY => undef, + UNIQUE_OR_PRIMARY => $table_info{$row->{table}}{columns}{$row->{to}} ? 'PRIMARY' : 'UNIQUE', + }; + push @fk_info, $fk_row; + push @{ $relid2rels{$row->{id}} }, $fk_row; # keep so can fixup + } + + # cribbed from DBIx::Class::Schema::Loader::DBI::SQLite + # but with additional parsing of which kind of deferrable + REL: for my $relid (keys %relid2rels) { + my $rel = $rels[$relid]; + my $deferrable = $DBI_code_for_rule{'NOT DEFERRABLE'}; + my $local_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $rel->{local_columns} }) . '"?'; + my $remote_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $rel->{remote_columns} || [] }) . '"?'; + my ($deferrable_clause) = $ddl =~ / + foreign \s+ key \s* \( \s* $local_cols \s* \) \s* references \s* (?:\S+|".+?(?{local_columns} } == 1) { + my ($local_col) = @{ $rel->{local_columns} }; + my ($remote_col) = @{ $rel->{remote_columns} || [] }; + $remote_col ||= ''; + ($deferrable_clause) = $ddl =~ / + "?\Q$local_col\E"? \s* (?:\w+\s*)* (?: \( \s* \d\+ (?:\s*,\s*\d+)* \s* \) )? \s* + references \s+ (?:\S+|".+?(?{DEFERRABILITY} = $deferrable for @{ $relid2rels{$relid} }; + } + } + } + + my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "") + or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); + my $sponge_sth = $sponge_dbh->prepare("foreign_key_info", { + NAME => \@FOREIGN_KEY_INFO_ODBC, + rows => [ map { [@{$_}{@FOREIGN_KEY_INFO_ODBC} ] } @fk_info ], + NUM_OF_FIELDS => scalar(@FOREIGN_KEY_INFO_ODBC), + }) or return $dbh->DBI::set_err( + $sponge_dbh->err, + $sponge_dbh->errstr, + ); + return $sponge_sth; +} + +my @STATISTICS_INFO_ODBC = ( + 'TABLE_CAT', # The catalog identifier. + 'TABLE_SCHEM', # The schema identifier. + 'TABLE_NAME', # The table identifier. + 'NON_UNIQUE', # Unique index indicator. + 'INDEX_QUALIFIER', # Index qualifier identifier. + 'INDEX_NAME', # The index identifier. + 'TYPE', # The type of information being returned. + 'ORDINAL_POSITION', # Column sequence number (starting with 1). + 'COLUMN_NAME', # The column identifier. + 'ASC_OR_DESC', # Column sort sequence. + 'CARDINALITY', # Cardinality of the table or index. + 'PAGES', # Number of storage pages used by this table or index. + 'FILTER_CONDITION', # The index filter condition as a string. +); + +sub statistics_info { + my ($dbh, $catalog, $schema, $table, $unique_only, $quick) = @_; + + my $databases = $dbh->selectall_arrayref("PRAGMA database_list", {Slice => {}}) or return; + + my @statistics_info; + for my $database (@$databases) { + my $dbname = $database->{name}; + next if defined $schema && $schema ne '%' && $schema ne $dbname; + + my $quoted_dbname = $dbh->quote_identifier($dbname); + my $master_table = + ($dbname eq 'main') ? 'sqlite_master' : + ($dbname eq 'temp') ? 'sqlite_temp_master' : + $quoted_dbname.'.sqlite_master'; + + my $tables = $dbh->selectall_arrayref("SELECT name FROM $master_table WHERE type = ?", undef, "table") or return; + for my $table_ref (@$tables) { + my $tbname = $table_ref->[0]; + next if defined $table && $table ne '%' && uc($table) ne uc($tbname); + + my $quoted_tbname = $dbh->quote_identifier($tbname); + my $sth = $dbh->prepare("PRAGMA $quoted_dbname.index_list($quoted_tbname)") or return; + $sth->execute or return; + while(my $row = $sth->fetchrow_hashref) { + + next if $unique_only && !$row->{unique}; + my $quoted_idx = $dbh->quote_identifier($row->{name}); + for my $db (@$databases) { + my $quoted_db = $dbh->quote_identifier($db->{name}); + my $i_sth = $dbh->prepare("PRAGMA $quoted_db.index_info($quoted_idx)") or return; + $i_sth->execute or return; + my $cols = {}; + while(my $info = $i_sth->fetchrow_hashref) { + push @statistics_info, { + TABLE_CAT => undef, + TABLE_SCHEM => $db->{name}, + TABLE_NAME => $tbname, + NON_UNIQUE => $row->{unique} ? 0 : 1, + INDEX_QUALIFIER => undef, + INDEX_NAME => $row->{name}, + TYPE => 'btree', # see https://www.sqlite.org/version3.html esp. "Traditional B-trees are still used for indices" + ORDINAL_POSITION => $info->{seqno} + 1, + COLUMN_NAME => $info->{name}, + ASC_OR_DESC => undef, + CARDINALITY => undef, + PAGES => undef, + FILTER_CONDITION => undef, + }; + } + } + } + } + } + + my $sponge_dbh = DBI->connect("DBI:Sponge:", "", "") + or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); + my $sponge_sth = $sponge_dbh->prepare("statistics_info", { + NAME => \@STATISTICS_INFO_ODBC, + rows => [ map { [@{$_}{@STATISTICS_INFO_ODBC} ] } @statistics_info ], + NUM_OF_FIELDS => scalar(@STATISTICS_INFO_ODBC), + }) or return $dbh->DBI::set_err( + $sponge_dbh->err, + $sponge_dbh->errstr, + ); + return $sponge_sth; +} + +my @TypeInfoKeys = qw/ + TYPE_NAME + DATA_TYPE + COLUMN_SIZE + LITERAL_PREFIX + LITERAL_SUFFIX + CREATE_PARAMS + NULLABLE + CASE_SENSITIVE + SEARCHABLE + UNSIGNED_ATTRIBUTE + FIXED_PREC_SCALE + AUTO_UNIQUE_VALUE + LOCAL_TYPE_NAME + MINIMUM_SCALE + MAXIMUM_SCALE + SQL_DATA_TYPE + SQL_DATETIME_SUB + NUM_PREC_RADIX + INTERVAL_PRECISION +/; + +my %TypeInfo = ( + SQL_INTEGER ,=> { + TYPE_NAME => 'INTEGER', + DATA_TYPE => SQL_INTEGER, + NULLABLE => 2, # no for integer primary key, otherwise yes + SEARCHABLE => 3, + }, + SQL_DOUBLE ,=> { + TYPE_NAME => 'REAL', + DATA_TYPE => SQL_DOUBLE, + NULLABLE => 1, + SEARCHABLE => 3, + }, + SQL_VARCHAR ,=> { + TYPE_NAME => 'TEXT', + DATA_TYPE => SQL_VARCHAR, + LITERAL_PREFIX => "'", + LITERAL_SUFFIX => "'", + NULLABLE => 1, + SEARCHABLE => 3, + }, + SQL_BLOB ,=> { + TYPE_NAME => 'BLOB', + DATA_TYPE => SQL_BLOB, + NULLABLE => 1, + SEARCHABLE => 3, + }, + SQL_UNKNOWN_TYPE ,=> { + DATA_TYPE => SQL_UNKNOWN_TYPE, + }, +); + +sub type_info_all { + my $idx = 0; + + my @info = ({map {$_ => $idx++} @TypeInfoKeys}); + for my $id (sort {$a <=> $b} keys %TypeInfo) { + push @info, [map {$TypeInfo{$id}{$_}} @TypeInfoKeys]; + } + return \@info; +} + +my @COLUMN_INFO = qw( + TABLE_CAT + TABLE_SCHEM + TABLE_NAME + COLUMN_NAME + DATA_TYPE + TYPE_NAME + COLUMN_SIZE + BUFFER_LENGTH + DECIMAL_DIGITS + NUM_PREC_RADIX + NULLABLE + REMARKS + COLUMN_DEF + SQL_DATA_TYPE + SQL_DATETIME_SUB + CHAR_OCTET_LENGTH + ORDINAL_POSITION + IS_NULLABLE +); + +sub column_info { + my ($dbh, $cat_val, $sch_val, $tbl_val, $col_val) = @_; + + if ( defined $col_val and $col_val eq '%' ) { + $col_val = undef; + } + + # Get a list of all tables ordered by TABLE_SCHEM, TABLE_NAME + my $sql = <<'END_SQL'; +SELECT TABLE_SCHEM, tbl_name TABLE_NAME +FROM ( + SELECT 'main' TABLE_SCHEM, tbl_name + FROM sqlite_master + WHERE type IN ('table','view') +UNION ALL + SELECT 'temp' TABLE_SCHEM, tbl_name + FROM sqlite_temp_master + WHERE type IN ('table','view') +END_SQL + + for my $db_name (_attached_database_list($dbh)) { + $sql .= <<"END_SQL"; +UNION ALL + SELECT '$db_name' TABLE_SCHEM, tbl_name + FROM "$db_name".sqlite_master + WHERE type IN ('table','view') +END_SQL + } + + $sql .= <<'END_SQL'; +UNION ALL + SELECT 'main' TABLE_SCHEM, 'sqlite_master' tbl_name +UNION ALL + SELECT 'temp' TABLE_SCHEM, 'sqlite_temp_master' tbl_name +) +END_SQL + + my @where; + if ( defined $sch_val ) { + push @where, "TABLE_SCHEM LIKE '$sch_val'"; + } + if ( defined $tbl_val ) { + push @where, "TABLE_NAME LIKE '$tbl_val'"; + } + $sql .= ' WHERE ' . join("\n AND ", @where ) . "\n" if @where; + $sql .= " ORDER BY TABLE_SCHEM, TABLE_NAME\n"; + my $sth_tables = $dbh->prepare($sql) or return undef; + $sth_tables->execute or return undef; + + # Taken from Fey::Loader::SQLite + my @cols; + while ( my ($schema, $table) = $sth_tables->fetchrow_array ) { + my $sth_columns = $dbh->prepare(qq{PRAGMA "$schema".table_info("$table")}) or return; + $sth_columns->execute or return; + + for ( my $position = 1; my $col_info = $sth_columns->fetchrow_hashref; $position++ ) { + if ( defined $col_val ) { + # This must do a LIKE comparison + my $sth = $dbh->prepare("SELECT '$col_info->{name}' LIKE '$col_val'") or return undef; + $sth->execute or return undef; + # Skip columns that don't match $col_val + next unless ($sth->fetchrow_array)[0]; + } + + my %col = ( + TABLE_SCHEM => $schema, + TABLE_NAME => $table, + COLUMN_NAME => $col_info->{name}, + ORDINAL_POSITION => $position, + ); + + my $type = $col_info->{type}; + if ( $type =~ s/(\w+)\s*\(\s*(\d+)(?:\s*,\s*(\d+))?\s*\)/$1/ ) { + $col{COLUMN_SIZE} = $2; + $col{DECIMAL_DIGITS} = $3; + } + + $col{TYPE_NAME} = $type; + + if ( defined $col_info->{dflt_value} ) { + $col{COLUMN_DEF} = $col_info->{dflt_value} + } + + if ( $col_info->{notnull} ) { + $col{NULLABLE} = 0; + $col{IS_NULLABLE} = 'NO'; + } else { + $col{NULLABLE} = 1; + $col{IS_NULLABLE} = 'YES'; + } + + push @cols, \%col; + } + $sth_columns->finish; + } + $sth_tables->finish; + + my $sponge = DBI->connect("DBI:Sponge:", '','') + or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); + $sponge->prepare( "column_info", { + rows => [ map { [ @{$_}{@COLUMN_INFO} ] } @cols ], + NUM_OF_FIELDS => scalar @COLUMN_INFO, + NAME => [ @COLUMN_INFO ], + } ) or return $dbh->DBI::set_err( + $sponge->err, + $sponge->errstr, + ); +} + +#====================================================================== +# An internal tied hash package used for %DBD::SQLite::COLLATION, to +# prevent people from unintentionally overriding globally registered collations. + +package # hide from PAUSE + DBD::SQLite::_WriteOnceHash; + +require Tie::Hash; + +our @ISA = qw(Tie::StdHash); + +sub TIEHASH { + bless {}, $_[0]; +} + +sub STORE { + ! exists $_[0]->{$_[1]} or die "entry $_[1] already registered"; + $_[0]->{$_[1]} = $_[2]; +} + +sub DELETE { + die "deletion of entry $_[1] is forbidden"; +} + +1; + +__END__ + +#line 2766 diff --git a/lib/DBD/SQLite/Constants.pm b/apps/lib/DBD/SQLite/Constants.pm similarity index 71% rename from lib/DBD/SQLite/Constants.pm rename to apps/lib/DBD/SQLite/Constants.pm index ae8a0f9..b1c33da 100644 --- a/lib/DBD/SQLite/Constants.pm +++ b/apps/lib/DBD/SQLite/Constants.pm @@ -1,3 +1,4 @@ +#line 1 "DBD/SQLite/Constants.pm" package DBD::SQLite::Constants; # This module is generated by a script. @@ -609,425 +610,6 @@ $EXPORT_TAGS{datatypes} = $EXPORT_TAGS{fundamental_datatypes}; __END__ -=encoding utf-8 -=head1 NAME - -DBD::SQLite::Constants - common SQLite constants - -=head1 SYNOPSIS - - DBD::SQLite::Constants qw/:result_codes/; - -=head1 DESCRIPTION - -You can import necessary SQLite constants from this module. Available tags are C, C, C, C (C), C, C, C (C), C, C (C), C, C. See L for the complete list of constants. - -This module does not export anything by default. - -=head1 CONSTANTS - -=head2 authorizer_action_codes - -=over 4 - -=item SQLITE_CREATE_INDEX - -=item SQLITE_CREATE_TABLE - -=item SQLITE_CREATE_TEMP_INDEX - -=item SQLITE_CREATE_TEMP_TABLE - -=item SQLITE_CREATE_TEMP_TRIGGER - -=item SQLITE_CREATE_TEMP_VIEW - -=item SQLITE_CREATE_TRIGGER - -=item SQLITE_CREATE_VIEW - -=item SQLITE_DELETE - -=item SQLITE_DROP_INDEX - -=item SQLITE_DROP_TABLE - -=item SQLITE_DROP_TEMP_INDEX - -=item SQLITE_DROP_TEMP_TABLE - -=item SQLITE_DROP_TEMP_TRIGGER - -=item SQLITE_DROP_TEMP_VIEW - -=item SQLITE_DROP_TRIGGER - -=item SQLITE_DROP_VIEW - -=item SQLITE_INSERT - -=item SQLITE_PRAGMA - -=item SQLITE_READ - -=item SQLITE_SELECT - -=item SQLITE_TRANSACTION - -=item SQLITE_UPDATE - -=item SQLITE_ATTACH - -=item SQLITE_DETACH - -=item SQLITE_ALTER_TABLE - -=item SQLITE_REINDEX - -=item SQLITE_ANALYZE - -=item SQLITE_CREATE_VTABLE - -=item SQLITE_DROP_VTABLE - -=item SQLITE_FUNCTION - -=item SQLITE_COPY - -=item SQLITE_SAVEPOINT - -=item SQLITE_RECURSIVE - -=back - -=head2 authorizer_return_codes - -=over 4 - -=item SQLITE_DENY - -=item SQLITE_IGNORE - -=back - -=head2 version (compile_time_library_version_numbers) - -=over 4 - -=item SQLITE_VERSION_NUMBER - -=back - -=head2 database_connection_configuration_options - -=over 4 - -=item SQLITE_DBCONFIG_LOOKASIDE - -=item SQLITE_DBCONFIG_ENABLE_FKEY - -=item SQLITE_DBCONFIG_ENABLE_TRIGGER - -=item SQLITE_DBCONFIG_ENABLE_FTS3_TOKENIZER - -=item SQLITE_DBCONFIG_ENABLE_LOAD_EXTENSION - -=item SQLITE_DBCONFIG_MAINDBNAME - -=item SQLITE_DBCONFIG_NO_CKPT_ON_CLOSE - -=item SQLITE_DBCONFIG_ENABLE_QPSG - -=item SQLITE_DBCONFIG_TRIGGER_EQP - -=item SQLITE_DBCONFIG_MAX - -=item SQLITE_DBCONFIG_RESET_DATABASE - -=item SQLITE_DBCONFIG_DEFENSIVE - -=back - -=head2 extended_result_codes - -=over 4 - -=item SQLITE_IOERR_LOCK - -=item SQLITE_IOERR_READ - -=item SQLITE_IOERR_SHORT_READ - -=item SQLITE_IOERR_WRITE - -=item SQLITE_IOERR_FSYNC - -=item SQLITE_IOERR_DIR_FSYNC - -=item SQLITE_IOERR_TRUNCATE - -=item SQLITE_IOERR_FSTAT - -=item SQLITE_IOERR_UNLOCK - -=item SQLITE_IOERR_RDLOCK - -=item SQLITE_IOERR_DELETE - -=item SQLITE_IOERR_BLOCKED - -=item SQLITE_IOERR_NOMEM - -=item SQLITE_IOERR_ACCESS - -=item SQLITE_IOERR_CHECKRESERVEDLOCK - -=item SQLITE_IOERR_CLOSE - -=item SQLITE_IOERR_DIR_CLOSE - -=item SQLITE_LOCKED_SHAREDCACHE - -=item SQLITE_IOERR_SHMOPEN - -=item SQLITE_IOERR_SHMSIZE - -=item SQLITE_IOERR_SHMLOCK - -=item SQLITE_BUSY_RECOVERY - -=item SQLITE_CANTOPEN_NOTEMPDIR - -=item SQLITE_IOERR_SHMMAP - -=item SQLITE_IOERR_SEEK - -=item SQLITE_CORRUPT_VTAB - -=item SQLITE_READONLY_RECOVERY - -=item SQLITE_READONLY_CANTLOCK - -=item SQLITE_ABORT_ROLLBACK - -=item SQLITE_CANTOPEN_ISDIR - -=item SQLITE_IOERR_DELETE_NOENT - -=item SQLITE_CANTOPEN_FULLPATH - -=item SQLITE_READONLY_ROLLBACK - -=item SQLITE_CONSTRAINT_CHECK - -=item SQLITE_CONSTRAINT_COMMITHOOK - -=item SQLITE_CONSTRAINT_FOREIGNKEY - -=item SQLITE_CONSTRAINT_FUNCTION - -=item SQLITE_CONSTRAINT_NOTNULL - -=item SQLITE_CONSTRAINT_PRIMARYKEY - -=item SQLITE_CONSTRAINT_TRIGGER - -=item SQLITE_CONSTRAINT_UNIQUE - -=item SQLITE_CONSTRAINT_VTAB - -=item SQLITE_IOERR_MMAP - -=item SQLITE_NOTICE_RECOVER_WAL - -=item SQLITE_NOTICE_RECOVER_ROLLBACK - -=item SQLITE_IOERR_GETTEMPPATH - -=item SQLITE_BUSY_SNAPSHOT - -=item SQLITE_WARNING_AUTOINDEX - -=item SQLITE_IOERR_CONVPATH - -=item SQLITE_CANTOPEN_CONVPATH - -=item SQLITE_CONSTRAINT_ROWID - -=item SQLITE_READONLY_DBMOVED - -=item SQLITE_AUTH_USER - -=item SQLITE_IOERR_VNODE - -=item SQLITE_IOERR_AUTH - -=item SQLITE_IOERR_BEGIN_ATOMIC - -=item SQLITE_IOERR_COMMIT_ATOMIC - -=item SQLITE_IOERR_ROLLBACK_ATOMIC - -=item SQLITE_ERROR_MISSING_COLLSEQ - -=item SQLITE_ERROR_RETRY - -=item SQLITE_READONLY_CANTINIT - -=item SQLITE_READONLY_DIRECTORY - -=item SQLITE_LOCKED_VTAB - -=item SQLITE_CORRUPT_SEQUENCE - -=item SQLITE_ERROR_SNAPSHOT - -=item SQLITE_CANTOPEN_DIRTYWAL - -=back - -=head2 file_open (flags_for_file_open_operations) - -=over 4 - -=item SQLITE_OPEN_READONLY - -=item SQLITE_OPEN_READWRITE - -=item SQLITE_OPEN_CREATE - -=item SQLITE_OPEN_NOMUTEX - -=item SQLITE_OPEN_FULLMUTEX - -=item SQLITE_OPEN_SHAREDCACHE - -=item SQLITE_OPEN_PRIVATECACHE - -=item SQLITE_OPEN_URI - -=item SQLITE_OPEN_MEMORY - -=back - -=head2 function_flags - -=over 4 - -=item SQLITE_DETERMINISTIC - -=back - -=head2 datatypes (fundamental_datatypes) - -=over 4 - -=item SQLITE_INTEGER - -=item SQLITE_FLOAT - -=item SQLITE_BLOB - -=item SQLITE_NULL - -=back - -=head2 result_codes - -=over 4 - -=item SQLITE_OK - -=item SQLITE_ERROR - -=item SQLITE_INTERNAL - -=item SQLITE_PERM - -=item SQLITE_ABORT - -=item SQLITE_BUSY - -=item SQLITE_LOCKED - -=item SQLITE_NOMEM - -=item SQLITE_READONLY - -=item SQLITE_INTERRUPT - -=item SQLITE_IOERR - -=item SQLITE_CORRUPT - -=item SQLITE_NOTFOUND - -=item SQLITE_FULL - -=item SQLITE_CANTOPEN - -=item SQLITE_PROTOCOL - -=item SQLITE_EMPTY - -=item SQLITE_SCHEMA - -=item SQLITE_TOOBIG - -=item SQLITE_CONSTRAINT - -=item SQLITE_MISMATCH - -=item SQLITE_MISUSE - -=item SQLITE_NOLFS - -=item SQLITE_AUTH - -=item SQLITE_FORMAT - -=item SQLITE_RANGE - -=item SQLITE_NOTADB - -=item SQLITE_ROW - -=item SQLITE_DONE - -=item SQLITE_NOTICE - -=item SQLITE_WARNING - -=back - -=head2 run_time_limit_categories - -=over 4 - -=item SQLITE_LIMIT_LENGTH - -=item SQLITE_LIMIT_SQL_LENGTH - -=item SQLITE_LIMIT_COLUMN - -=item SQLITE_LIMIT_EXPR_DEPTH - -=item SQLITE_LIMIT_COMPOUND_SELECT - -=item SQLITE_LIMIT_VDBE_OP - -=item SQLITE_LIMIT_FUNCTION_ARG - -=item SQLITE_LIMIT_ATTACHED - -=item SQLITE_LIMIT_LIKE_PATTERN_LENGTH - -=item SQLITE_LIMIT_VARIABLE_NUMBER - -=item SQLITE_LIMIT_TRIGGER_DEPTH - -=item SQLITE_LIMIT_WORKER_THREADS - -=back +#line 1034 diff --git a/lib/DBD/SQLite/GetInfo.pm b/apps/lib/DBD/SQLite/GetInfo.pm similarity index 99% rename from lib/DBD/SQLite/GetInfo.pm rename to apps/lib/DBD/SQLite/GetInfo.pm index 083bfa4..e1ac444 100644 --- a/lib/DBD/SQLite/GetInfo.pm +++ b/apps/lib/DBD/SQLite/GetInfo.pm @@ -1,3 +1,4 @@ +#line 1 "DBD/SQLite/GetInfo.pm" package DBD::SQLite::GetInfo; use 5.006; diff --git a/apps/lib/DBD/SQLite/VirtualTable.pm b/apps/lib/DBD/SQLite/VirtualTable.pm new file mode 100644 index 0000000..3a2ba3c --- /dev/null +++ b/apps/lib/DBD/SQLite/VirtualTable.pm @@ -0,0 +1,227 @@ +#line 1 "DBD/SQLite/VirtualTable.pm" +#====================================================================== +package DBD::SQLite::VirtualTable; +#====================================================================== +use strict; +use warnings; +use Scalar::Util qw/weaken/; + +our $VERSION = '1.62'; +our @ISA; + + +#---------------------------------------------------------------------- +# methods for registering/destroying the module +#---------------------------------------------------------------------- + +sub CREATE_MODULE { my ($class, $mod_name) = @_; } +sub DESTROY_MODULE { my ($class, $mod_name) = @_; } + +#---------------------------------------------------------------------- +# methods for creating/destroying instances +#---------------------------------------------------------------------- + +sub CREATE { my $class = shift; return $class->NEW(@_); } +sub CONNECT { my $class = shift; return $class->NEW(@_); } + +sub _PREPARE_SELF { + my ($class, $dbh_ref, $module_name, $db_name, $vtab_name, @args) = @_; + + my @columns; + my %options; + + # args containing '=' are options; others are column declarations + foreach my $arg (@args) { + if ($arg =~ /^([^=\s]+)\s*=\s*(.*)/) { + my ($key, $val) = ($1, $2); + $val =~ s/^"(.*)"$/$1/; + $options{$key} = $val; + } + else { + push @columns, $arg; + } + } + + # build $self + my $self = { + dbh_ref => $dbh_ref, + module_name => $module_name, + db_name => $db_name, + vtab_name => $vtab_name, + columns => \@columns, + options => \%options, + }; + weaken $self->{dbh_ref}; + + return $self; +} + +sub NEW { + my $class = shift; + + my $self = $class->_PREPARE_SELF(@_); + bless $self, $class; +} + + +sub VTAB_TO_DECLARE { + my $self = shift; + + local $" = ", "; + my $sql = "CREATE TABLE $self->{vtab_name}(@{$self->{columns}})"; + + return $sql; +} + +sub DROP { my $self = shift; } +sub DISCONNECT { my $self = shift; } + + +#---------------------------------------------------------------------- +# methods for initiating a search +#---------------------------------------------------------------------- + +sub BEST_INDEX { + my ($self, $constraints, $order_by) = @_; + + my $ix = 0; + foreach my $constraint (grep {$_->{usable}} @$constraints) { + $constraint->{argvIndex} = $ix++; + $constraint->{omit} = 0; + } + + # stupid default values -- subclasses should put real values instead + my $outputs = { + idxNum => 1, + idxStr => "", + orderByConsumed => 0, + estimatedCost => 1.0, + estimatedRows => undef, + }; + + return $outputs; +} + + +sub OPEN { + my $self = shift; + my $class = ref $self; + + my $cursor_class = $class . "::Cursor"; + return $cursor_class->NEW($self, @_); +} + + +#---------------------------------------------------------------------- +# methods for insert/delete/update +#---------------------------------------------------------------------- + +sub _SQLITE_UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; + + if (! defined $old_rowid) { + return $self->INSERT($new_rowid, @values); + } + elsif (!@values) { + return $self->DELETE($old_rowid); + } + else { + return $self->UPDATE($old_rowid, $new_rowid, @values); + } +} + +sub INSERT { + my ($self, $new_rowid, @values) = @_; + + die "INSERT() should be redefined in subclass"; +} + +sub DELETE { + my ($self, $old_rowid) = @_; + + die "DELETE() should be redefined in subclass"; +} + +sub UPDATE { + my ($self, $old_rowid, $new_rowid, @values) = @_; + + die "UPDATE() should be redefined in subclass"; +} + +#---------------------------------------------------------------------- +# remaining methods of the sqlite API +#---------------------------------------------------------------------- + +sub BEGIN_TRANSACTION {return 0} +sub SYNC_TRANSACTION {return 0} +sub COMMIT_TRANSACTION {return 0} +sub ROLLBACK_TRANSACTION {return 0} +sub SAVEPOINT {return 0} +sub RELEASE {return 0} +sub ROLLBACK_TO {return 0} +sub FIND_FUNCTION {return 0} +sub RENAME {return 0} + + +#---------------------------------------------------------------------- +# utility methods +#---------------------------------------------------------------------- + +sub dbh { + my $self = shift; + return ${$self->{dbh_ref}}; +} + + +sub sqlite_table_info { + my $self = shift; + + my $sql = "PRAGMA table_info($self->{vtab_name})"; + return $self->dbh->selectall_arrayref($sql, {Slice => {}}); +} + +#====================================================================== +package DBD::SQLite::VirtualTable::Cursor; +#====================================================================== +use strict; +use warnings; + +sub NEW { + my ($class, $vtable, @args) = @_; + my $self = {vtable => $vtable, + args => \@args}; + bless $self, $class; +} + + +sub FILTER { + my ($self, $idxNum, $idxStr, @values) = @_; + die "FILTER() should be redefined in cursor subclass"; +} + +sub EOF { + my ($self) = @_; + die "EOF() should be redefined in cursor subclass"; +} + +sub NEXT { + my ($self) = @_; + die "NEXT() should be redefined in cursor subclass"; +} + +sub COLUMN { + my ($self, $idxCol) = @_; + die "COLUMN() should be redefined in cursor subclass"; +} + +sub ROWID { + my ($self) = @_; + die "ROWID() should be redefined in cursor subclass"; +} + + +1; + +__END__ + +#line 825 diff --git a/lib/DBD/SQLite/VirtualTable/FileContent.pm b/apps/lib/DBD/SQLite/VirtualTable/FileContent.pm similarity index 71% rename from lib/DBD/SQLite/VirtualTable/FileContent.pm rename to apps/lib/DBD/SQLite/VirtualTable/FileContent.pm index 0fe8535..5380705 100644 --- a/lib/DBD/SQLite/VirtualTable/FileContent.pm +++ b/apps/lib/DBD/SQLite/VirtualTable/FileContent.pm @@ -1,3 +1,4 @@ +#line 1 "DBD/SQLite/VirtualTable/FileContent.pm" #====================================================================== package DBD::SQLite::VirtualTable::FileContent; #====================================================================== @@ -236,98 +237,4 @@ sub file_content { __END__ -=head1 NAME - -DBD::SQLite::VirtualTable::FileContent -- virtual table for viewing file contents - - -=head1 SYNOPSIS - -Within Perl : - - $dbh->sqlite_create_module(fcontent => "DBD::SQLite::VirtualTable::FileContent"); - -Then, within SQL : - - CREATE VIRTUAL TABLE tbl USING fcontent( - source = src_table, - content_col = content, - path_col = path, - expose = "path, col1, col2, col3", -- or "*" - root = "/foo/bar" - get_content = Foo::Bar::read_from_file - ); - - SELECT col1, path, content FROM tbl WHERE ...; - -=head1 DESCRIPTION - -A "FileContent" virtual table is bound to some underlying I, which has a column containing paths to files. The virtual -table behaves like a database view on the source table, with an added -column which exposes the content from those files. - -This is especially useful as an "external content" to some -fulltext table (see L) : the index -table stores some metadata about files, and then the fulltext engine -can index both the metadata and the file contents. - -=head1 PARAMETERS - -Parameters for creating a C virtual table are -specified within the C statement, just -like regular column declarations, but with an '=' sign. -Authorized parameters are : - -=over - -=item C - -The name of the I. -This parameter is mandatory. All other parameters are optional. - -=item C - -The name of the virtual column exposing file contents. -The default is C. - -=item C - -The name of the column in C that contains paths to files. -The default is C. - -=item C - -A comma-separated list (within double quotes) of source column names -to be exposed by the virtual table. The default is C<"*">, which means -all source columns. - -=item C - -An optional root directory that will be prepended to the I column -when opening files. - -=item C - -Fully qualified name of a Perl function for reading file contents. -The default implementation just slurps the entire file into a string; -but this hook can point to more sophisticated implementations, like for -example a function that would remove html tags. The hooked function is -called like this : - - $file_content = $get_content->($path, $root); - -=back - -=head1 AUTHOR - -Laurent Dami Edami@cpan.orgE - -=head1 COPYRIGHT AND LICENSE - -Copyright Laurent Dami, 2014. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut +#line 334 diff --git a/lib/DBD/SQLite/VirtualTable/PerlData.pm b/apps/lib/DBD/SQLite/VirtualTable/PerlData.pm similarity index 54% rename from lib/DBD/SQLite/VirtualTable/PerlData.pm rename to apps/lib/DBD/SQLite/VirtualTable/PerlData.pm index 39ca09b..4d6f48f 100644 --- a/lib/DBD/SQLite/VirtualTable/PerlData.pm +++ b/apps/lib/DBD/SQLite/VirtualTable/PerlData.pm @@ -1,3 +1,4 @@ +#line 1 "DBD/SQLite/VirtualTable/PerlData.pm" #====================================================================== package DBD::SQLite::VirtualTable::PerlData; #====================================================================== @@ -274,215 +275,4 @@ sub ROWID { __END__ -=head1 NAME - -DBD::SQLite::VirtualTable::PerlData -- virtual table hooked to Perl data - -=head1 SYNOPSIS - -Within Perl : - - $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); - -Then, within SQL : - - - CREATE VIRTUAL TABLE atbl USING perl(foo, bar, etc, - arrayrefs="some::global::var::aref") - - CREATE VIRTUAL TABLE htbl USING perl(foo, bar, etc, - hashrefs="some::global::var::href") - - CREATE VIRTUAL TABLE ctbl USING perl(single_col - colref="some::global::var::ref") - - - SELECT foo, bar FROM atbl WHERE ...; - - -=head1 DESCRIPTION - -A C virtual table is a database view on some datastructure -within a Perl program. The data can be read or modified both from SQL -and from Perl. This is useful for simple import/export -operations, for debugging purposes, for joining data from different -sources, etc. - - -=head1 PARAMETERS - -Parameters for creating a C virtual table are specified -within the C statement, mixed with regular -column declarations, but with an '=' sign. - -The only authorized (and mandatory) parameter is the one that -specifies the Perl datastructure to which the virtual table is bound. -It must be given as the fully qualified name of a global variable; -the parameter can be one of three different kinds : - -=over - -=item C - -arrayref that contains an arrayref for each row. -Each such row will have a size equivalent to the number -of columns declared for the virtual table. - -=item C - -arrayref that contains a hashref for each row. -Keys in each hashref should correspond to the -columns declared for the virtual table. - -=item C - -arrayref that contains a single scalar for each row; -obviously, this is a single-column virtual table. - -=back - -=head1 USAGE - -=head2 Common part of all examples : declaring the module - -In all examples below, the common part is that the Perl -program should connect to the database and then declare the -C virtual table module, like this - - # connect to the database - my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", '', '', - {RaiseError => 1, AutoCommit => 1}); - # or any other options suitable to your needs - - # register the module - $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); - -Then create a global arrayref variable, using C instead of C, -so that the variable is stored in the symbol table of the enclosing module. - - package Foo::Bar; # could as well be just "main" - our $rows = [ ... ]; - -Finally, create the virtual table and bind it to the global -variable (here we assume that C<@$rows> contains arrayrefs) : - - $dbh->do('CREATE VIRTUAL TABLE temp.vtab' - .' USING perl(col1 INT, col2 TEXT, etc, - arrayrefs="Foo::Bar::rows'); - -In most cases, the virtual table will be for temporary use, which is -the reason why this example prepends C in front of the table -name : this tells SQLite to cleanup that table when the database -handle will be disconnected, without the need to emit an explicit DROP -statement. - -Column names (and optionally their types) are specified in the -virtual table declaration, just like for any regular table. - -=head2 Arrayref example : statistics from files - -Let's suppose we want to perform some searches over a collection of -files, where search constraints may be based on some of the fields -returned by L, such as the size of the file or its last modify -time. Here is a way to do it with a virtual table : - - my @files = ... ; # list of files to inspect - - # apply the L function to each file - our $file_stats = [ map { [ $_, stat $_ ] } @files]; - - # create a temporary virtual table - $dbh->do(<<""); - CREATE VIRTUAL TABLE temp.file_stats' - USING perl(path, dev, ino, mode, nlink, uid, gid, rdev, size, - atime, mtime, ctime, blksize, blocks, - arrayrefs="main::file_stats"); - - # search files - my $sth = $dbh->prepare(<<""); - SELECT * FROM file_stats - WHERE mtime BETWEEN ? AND ? - AND uid IN (...) - -=head2 Hashref example : unicode characters - -Given any unicode character, the L function -returns a hashref with various bits of information about that character. -So this can be exploited in a virtual table : - - use Unicode::UCD 'charinfo'; - our $chars = [map {charinfo($_)} 0x300..0x400]; # arbitrary subrange - - # create a temporary virtual table - $dbh->do(<<""); - CREATE VIRTUAL TABLE charinfo USING perl( - code, name, block, script, category, - hashrefs="main::chars" - ) - - # search characters - my $sth = $dbh->prepare(<<""); - SELECT * FROM charinfo - WHERE script='Greek' - AND name LIKE '%SIGMA%' - - -=head2 Colref example: SELECT WHERE ... IN ... - -I file in SQLite's source -(L).> - -A C virtual table is designed to facilitate using an -array of values as the right-hand side of an IN operator. The -usual syntax for IN is to prepare a statement like this: - - SELECT * FROM table WHERE x IN (?,?,?,...,?); - -and then bind individual values to each of the ? slots; but this has -the disadvantage that the number of values must be known in -advance. Instead, we can store values in a Perl array, bind that array -to a virtual table, and then write a statement like this - - SELECT * FROM table WHERE x IN perl_array; - -Here is how such a program would look like : - - # connect to the database - my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile", '', '', - {RaiseError => 1, AutoCommit => 1}); - - # Declare a global arrayref containing the values. Here we assume - # they are taken from @ARGV, but any other datasource would do. - # Note the use of "our" instead of "my". - our $values = \@ARGV; - - # register the module and declare the virtual table - $dbh->sqlite_create_module(perl => "DBD::SQLite::VirtualTable::PerlData"); - $dbh->do('CREATE VIRTUAL TABLE temp.intarray' - .' USING perl(i INT, colref="main::values'); - - # now we can SELECT from another table, using the intarray as a constraint - my $sql = "SELECT * FROM some_table WHERE some_col IN intarray"; - my $result = $dbh->selectall_arrayref($sql); - - -Beware that the virtual table is read-write, so the statement below -would push 99 into @ARGV ! - - INSERT INTO intarray VALUES (99); - - - -=head1 AUTHOR - -Laurent Dami Edami@cpan.orgE - -=head1 COPYRIGHT AND LICENSE - -Copyright Laurent Dami, 2014. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut +#line 489 diff --git a/apps/lib/DBD/Sponge.pm b/apps/lib/DBD/Sponge.pm new file mode 100644 index 0000000..1c593c9 --- /dev/null +++ b/apps/lib/DBD/Sponge.pm @@ -0,0 +1,220 @@ +#line 1 "DBD/Sponge.pm" +use strict; +{ + package DBD::Sponge; + + require DBI; + require Carp; + + our @EXPORT = qw(); # Do NOT @EXPORT anything. + our $VERSION = "12.010003"; + +# $Id: Sponge.pm 10002 2007-09-26 21:03:25Z Tim $ +# +# Copyright (c) 1994-2003 Tim Bunce Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + our $drh = undef; # holds driver handle once initialised + my $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBD::Sponge::db->install_method("sponge_test_installed_method") + unless $methods_already_installed++; + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Sponge', + 'Version' => $VERSION, + 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", + }); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::Sponge::dr; # ====== DRIVER ====== + our $imp_data_size = 0; + # we use default (dummy) connect method +} + + +{ package DBD::Sponge::db; # ====== DATABASE ====== + our $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement, $attribs) = @_; + my $rows = delete $attribs->{'rows'} + or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare"); + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + 'rows' => $rows, + (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () } + qw(execute_hook) + ), + }); + if (my $behave_like = $attribs->{behave_like}) { + $outer->{$_} = $behave_like->{$_} + foreach (qw(RaiseError PrintError HandleError ShowErrorStatement)); + } + + if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array() + $sth->{is_insert} = 1; + my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS} + or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement"); + $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} ); + } + else { #assume select + + # we need to set NUM_OF_FIELDS + my $numFields; + if ($attribs->{'NUM_OF_FIELDS'}) { + $numFields = $attribs->{'NUM_OF_FIELDS'}; + } elsif ($attribs->{'NAME'}) { + $numFields = @{$attribs->{NAME}}; + } elsif ($attribs->{'TYPE'}) { + $numFields = @{$attribs->{TYPE}}; + } elsif (my $firstrow = $rows->[0]) { + $numFields = scalar @$firstrow; + } else { + return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS'); + } + $sth->STORE('NUM_OF_FIELDS' => $numFields); + $sth->{NAME} = $attribs->{NAME} + || [ map { "col$_" } 1..$numFields ]; + $sth->{TYPE} = $attribs->{TYPE} + || [ (DBI::SQL_VARCHAR()) x $numFields ]; + $sth->{PRECISION} = $attribs->{PRECISION} + || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ]; + $sth->{SCALE} = $attribs->{SCALE} + || [ (0) x $numFields ]; + $sth->{NULLABLE} = $attribs->{NULLABLE} + || [ (2) x $numFields ]; + } + + $outer; + } + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + PRECISION => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + MONEY => 10, + AUTO_INCREMENT => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return 1 if $attrib eq 'AutoCommit'; + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + return 1 if $value; # is already set + Carp::croak("Can't disable AutoCommit"); + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub sponge_test_installed_method { + my ($dbh, @args) = @_; + return $dbh->set_err(42, "not enough parameters") unless @args >= 2; + return \@args; + } +} + + +{ package DBD::Sponge::st; # ====== STATEMENT ====== + our $imp_data_size = 0; + use strict; + + sub execute { + my $sth = shift; + + # hack to support ParamValues (when not using bind_param) + $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef; + + if (my $hook = $sth->{execute_hook}) { + &$hook($sth, @_) or return; + } + + if ($sth->{is_insert}) { + my $row; + $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ; + my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS}; + return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected") + if @$row != $NUM_OF_PARAMS; + { local $^W; $sth->trace_msg("inserting (@$row)\n"); } + push @{ $sth->{rows} }, $row; + } + else { # mark select sth as Active + $sth->STORE(Active => 1); + } + # else do nothing for select as data is already in $sth->{rows} + return 1; + } + + sub fetch { + my ($sth) = @_; + my $row = shift @{$sth->{'rows'}}; + unless ($row) { + $sth->STORE(Active => 0); + return undef; + } + return $sth->_set_fbav($row); + } + *fetchrow_arrayref = \&fetch; + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } +} + +1; + +__END__ + +#line 306 diff --git a/apps/lib/DBD/mysql.pm b/apps/lib/DBD/mysql.pm new file mode 100644 index 0000000..e942256 --- /dev/null +++ b/apps/lib/DBD/mysql.pm @@ -0,0 +1,890 @@ +#!/usr/bin/perl +#line 2 "DBD/mysql.pm" + +use strict; +use warnings; +require 5.008_001; # just as DBI + +package DBD::mysql; + +use DBI; +use DynaLoader(); +use Carp; +our @ISA = qw(DynaLoader); + +# please make sure the sub-version does not increase above '099' +# SQL_DRIVER_VER is formatted as dd.dd.dddd +# for version 5.x please switch to 5.00(_00) version numbering +# keep $VERSION in Bundle/DBD/mysql.pm in sync +our $VERSION = '4.041'; + +bootstrap DBD::mysql $VERSION; + + +our $err = 0; # holds error code for DBI::err +our $errstr = ""; # holds error string for DBI::errstr +our $drh = undef; # holds driver handle once initialised + +my $methods_are_installed = 0; +sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + + $class .= "::dr"; + + # not a 'my' since we use it above to prevent multiple drivers + $drh = DBI::_new_drh($class, { 'Name' => 'mysql', + 'Version' => $VERSION, + 'Err' => \$DBD::mysql::err, + 'Errstr' => \$DBD::mysql::errstr, + 'Attribution' => 'DBD::mysql by Patrick Galbraith' + }); + + if (!$methods_are_installed) { + DBD::mysql::db->install_method('mysql_fd'); + DBD::mysql::db->install_method('mysql_async_result'); + DBD::mysql::db->install_method('mysql_async_ready'); + DBD::mysql::st->install_method('mysql_async_result'); + DBD::mysql::st->install_method('mysql_async_ready'); + + $methods_are_installed++; + } + + $drh; +} + +sub CLONE { + undef $drh; +} + +sub _OdbcParse($$$) { + my($class, $dsn, $hash, $args) = @_; + my($var, $val); + if (!defined($dsn)) { + return; + } + while (length($dsn)) { + if ($dsn =~ /([^:;]*\[.*]|[^:;]*)[:;](.*)/) { + $val = $1; + $dsn = $2; + $val =~ s/\[|]//g; # Remove [] if present, the rest of the code prefers plain IPv6 addresses + } else { + $val = $dsn; + $dsn = ''; + } + if ($val =~ /([^=]*)=(.*)/) { + $var = $1; + $val = $2; + if ($var eq 'hostname' || $var eq 'host') { + $hash->{'host'} = $val; + } elsif ($var eq 'db' || $var eq 'dbname') { + $hash->{'database'} = $val; + } else { + $hash->{$var} = $val; + } + } else { + foreach $var (@$args) { + if (!defined($hash->{$var})) { + $hash->{$var} = $val; + last; + } + } + } + } +} + +sub _OdbcParseHost ($$) { + my($class, $dsn) = @_; + my($hash) = {}; + $class->_OdbcParse($dsn, $hash, ['host', 'port']); + ($hash->{'host'}, $hash->{'port'}); +} + +sub AUTOLOAD { + my ($meth) = $DBD::mysql::AUTOLOAD; + my ($smeth) = $meth; + $smeth =~ s/(.*)\:\://; + + my $val = constant($smeth, @_ ? $_[0] : 0); + if ($! == 0) { eval "sub $meth { $val }"; return $val; } + + Carp::croak "$meth: Not defined"; +} + +1; + + +package DBD::mysql::dr; # ====== DRIVER ====== +use strict; +use DBI qw(:sql_types); +use DBI::Const::GetInfoType; + +sub connect { + my($drh, $dsn, $username, $password, $attrhash) = @_; + my($port); + my($cWarn); + my $connect_ref= { 'Name' => $dsn }; + my $dbi_imp_data; + + # Avoid warnings for undefined values + $username ||= ''; + $password ||= ''; + $attrhash ||= {}; + $attrhash->{mysql_conn_attrs} ||= {}; + $attrhash->{mysql_conn_attrs}->{'program_name'} ||= $0; + + # create a 'blank' dbh + my($this, $privateAttrHash) = (undef, $attrhash); + $privateAttrHash = { %$privateAttrHash, + 'Name' => $dsn, + 'user' => $username, + 'password' => $password + }; + + DBD::mysql->_OdbcParse($dsn, $privateAttrHash, + ['database', 'host', 'port']); + + + if ($DBI::VERSION >= 1.49) + { + $dbi_imp_data = delete $attrhash->{dbi_imp_data}; + $connect_ref->{'dbi_imp_data'} = $dbi_imp_data; + } + + if (!defined($this = DBI::_new_dbh($drh, + $connect_ref, + $privateAttrHash))) + { + return undef; + } + + DBD::mysql::db::_login($this, $dsn, $username, $password) + or $this = undef; + + if ($this && ($ENV{MOD_PERL} || $ENV{GATEWAY_INTERFACE})) { + $this->{mysql_auto_reconnect} = 1; + } + $this; +} + +sub data_sources { + my($self) = shift; + my($attributes) = shift; + my($host, $port, $user, $password) = ('', '', '', ''); + if ($attributes) { + $host = $attributes->{host} || ''; + $port = $attributes->{port} || ''; + $user = $attributes->{user} || ''; + $password = $attributes->{password} || ''; + } + my(@dsn) = $self->func($host, $port, $user, $password, '_ListDBs'); + my($i); + for ($i = 0; $i < @dsn; $i++) { + $dsn[$i] = "DBI:mysql:$dsn[$i]"; + } + @dsn; +} + +sub admin { + my($drh) = shift; + my($command) = shift; + my($dbname) = ($command eq 'createdb' || $command eq 'dropdb') ? + shift : ''; + my($host, $port) = DBD::mysql->_OdbcParseHost(shift(@_) || ''); + my($user) = shift || ''; + my($password) = shift || ''; + + $drh->func(undef, $command, + $dbname || '', + $host || '', + $port || '', + $user, $password, '_admin_internal'); +} + +package DBD::mysql::db; # ====== DATABASE ====== +use strict; +use DBI qw(:sql_types); + +%DBD::mysql::db::db2ANSI = ( + "INT" => "INTEGER", + "CHAR" => "CHAR", + "REAL" => "REAL", + "IDENT" => "DECIMAL" +); + +### ANSI datatype mapping to MySQL datatypes +%DBD::mysql::db::ANSI2db = ( + "CHAR" => "CHAR", + "VARCHAR" => "CHAR", + "LONGVARCHAR" => "CHAR", + "NUMERIC" => "INTEGER", + "DECIMAL" => "INTEGER", + "BIT" => "INTEGER", + "TINYINT" => "INTEGER", + "SMALLINT" => "INTEGER", + "INTEGER" => "INTEGER", + "BIGINT" => "INTEGER", + "REAL" => "REAL", + "FLOAT" => "REAL", + "DOUBLE" => "REAL", + "BINARY" => "CHAR", + "VARBINARY" => "CHAR", + "LONGVARBINARY" => "CHAR", + "DATE" => "CHAR", + "TIME" => "CHAR", + "TIMESTAMP" => "CHAR" +); + +sub prepare { + my($dbh, $statement, $attribs)= @_; + + return unless $dbh->func('_async_check'); + + # create a 'blank' dbh + my $sth = DBI::_new_sth($dbh, {'Statement' => $statement}); + + # Populate internal handle data. + if (!DBD::mysql::st::_prepare($sth, $statement, $attribs)) { + $sth = undef; + } + + $sth; +} + +sub db2ANSI { + my $self = shift; + my $type = shift; + return $DBD::mysql::db::db2ANSI{"$type"}; +} + +sub ANSI2db { + my $self = shift; + my $type = shift; + return $DBD::mysql::db::ANSI2db{"$type"}; +} + +sub admin { + my($dbh) = shift; + my($command) = shift; + my($dbname) = ($command eq 'createdb' || $command eq 'dropdb') ? + shift : ''; + $dbh->{'Driver'}->func($dbh, $command, $dbname, '', '', '', + '_admin_internal'); +} + +sub _SelectDB ($$) { + die "_SelectDB is removed from this module; use DBI->connect instead."; +} + +sub table_info ($) { + my ($dbh, $catalog, $schema, $table, $type, $attr) = @_; + $dbh->{mysql_server_prepare}||= 0; + my $mysql_server_prepare_save= $dbh->{mysql_server_prepare}; + $dbh->{mysql_server_prepare}= 0; + my @names = qw(TABLE_CAT TABLE_SCHEM TABLE_NAME TABLE_TYPE REMARKS); + my @rows; + + my $sponge = DBI->connect("DBI:Sponge:", '','') + or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr"); + +# Return the list of catalogs + if (defined $catalog && $catalog eq "%" && + (!defined($schema) || $schema eq "") && + (!defined($table) || $table eq "")) + { + @rows = (); # Empty, because MySQL doesn't support catalogs (yet) + } + # Return the list of schemas + elsif (defined $schema && $schema eq "%" && + (!defined($catalog) || $catalog eq "") && + (!defined($table) || $table eq "")) + { + my $sth = $dbh->prepare("SHOW DATABASES") + or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return undef); + + $sth->execute() + or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return DBI::set_err($dbh, $sth->err(), $sth->errstr())); + + while (my $ref = $sth->fetchrow_arrayref()) + { + push(@rows, [ undef, $ref->[0], undef, undef, undef ]); + } + } + # Return the list of table types + elsif (defined $type && $type eq "%" && + (!defined($catalog) || $catalog eq "") && + (!defined($schema) || $schema eq "") && + (!defined($table) || $table eq "")) + { + @rows = ( + [ undef, undef, undef, "TABLE", undef ], + [ undef, undef, undef, "VIEW", undef ], + ); + } + # Special case: a catalog other than undef, "", or "%" + elsif (defined $catalog && $catalog ne "" && $catalog ne "%") + { + @rows = (); # Nothing, because MySQL doesn't support catalogs yet. + } + # Uh oh, we actually have a meaty table_info call. Work is required! + else + { + my @schemas; + # If no table was specified, we want them all + $table ||= "%"; + + # If something was given for the schema, we need to expand it to + # a list of schemas, since it may be a wildcard. + if (defined $schema && $schema ne "") + { + my $sth = $dbh->prepare("SHOW DATABASES LIKE " . + $dbh->quote($schema)) + or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return undef); + $sth->execute() + or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return DBI::set_err($dbh, $sth->err(), $sth->errstr())); + + while (my $ref = $sth->fetchrow_arrayref()) + { + push @schemas, $ref->[0]; + } + } + # Otherwise we want the current database + else + { + push @schemas, $dbh->selectrow_array("SELECT DATABASE()"); + } + + # Figure out which table types are desired + my ($want_tables, $want_views); + if (defined $type && $type ne "") + { + $want_tables = ($type =~ m/table/i); + $want_views = ($type =~ m/view/i); + } + else + { + $want_tables = $want_views = 1; + } + + for my $database (@schemas) + { + my $sth = $dbh->prepare("SHOW /*!50002 FULL*/ TABLES FROM " . + $dbh->quote_identifier($database) . + " LIKE " . $dbh->quote($table)) + or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return undef); + + $sth->execute() or + ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return DBI::set_err($dbh, $sth->err(), $sth->errstr())); + + while (my $ref = $sth->fetchrow_arrayref()) + { + my $type = (defined $ref->[1] && + $ref->[1] =~ /view/i) ? 'VIEW' : 'TABLE'; + next if $type eq 'TABLE' && not $want_tables; + next if $type eq 'VIEW' && not $want_views; + push @rows, [ undef, $database, $ref->[0], $type, undef ]; + } + } + } + + my $sth = $sponge->prepare("table_info", + { + rows => \@rows, + NUM_OF_FIELDS => scalar @names, + NAME => \@names, + }) + or ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); + + $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; + return $sth; +} + +sub _ListTables { + my $dbh = shift; + if (!$DBD::mysql::QUIET) { + warn "_ListTables is deprecated, use \$dbh->tables()"; + } + return map { $_ =~ s/.*\.//; $_ } $dbh->tables(); +} + + +sub column_info { + my ($dbh, $catalog, $schema, $table, $column) = @_; + + return unless $dbh->func('_async_check'); + + $dbh->{mysql_server_prepare}||= 0; + my $mysql_server_prepare_save= $dbh->{mysql_server_prepare}; + $dbh->{mysql_server_prepare}= 0; + + # ODBC allows a NULL to mean all columns, so we'll accept undef + $column = '%' unless defined $column; + + my $ER_NO_SUCH_TABLE= 1146; + + my $table_id = $dbh->quote_identifier($catalog, $schema, $table); + + my @names = qw( + TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME + DATA_TYPE TYPE_NAME COLUMN_SIZE BUFFER_LENGTH DECIMAL_DIGITS + NUM_PREC_RADIX NULLABLE REMARKS COLUMN_DEF + SQL_DATA_TYPE SQL_DATETIME_SUB CHAR_OCTET_LENGTH + ORDINAL_POSITION IS_NULLABLE CHAR_SET_CAT + CHAR_SET_SCHEM CHAR_SET_NAME COLLATION_CAT COLLATION_SCHEM COLLATION_NAME + UDT_CAT UDT_SCHEM UDT_NAME DOMAIN_CAT DOMAIN_SCHEM DOMAIN_NAME + SCOPE_CAT SCOPE_SCHEM SCOPE_NAME MAX_CARDINALITY + DTD_IDENTIFIER IS_SELF_REF + mysql_is_pri_key mysql_type_name mysql_values + mysql_is_auto_increment + ); + my %col_info; + + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + # only ignore ER_NO_SUCH_TABLE in internal_execute if issued from here + my $desc_sth = $dbh->prepare("DESCRIBE $table_id " . $dbh->quote($column)); + my $desc = $dbh->selectall_arrayref($desc_sth, { Columns=>{} }); + + #return $desc_sth if $desc_sth->err(); + if (my $err = $desc_sth->err()) + { + # return the error, unless it is due to the table not + # existing per DBI spec + if ($err != $ER_NO_SUCH_TABLE) + { + $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; + return undef; + } + $dbh->set_err(undef,undef); + $desc = []; + } + + my $ordinal_pos = 0; + my @fields; + for my $row (@$desc) + { + my $type = $row->{type}; + $type =~ m/^(\w+)(\((.+)\))?\s?(.*)?$/; + my $basetype = lc($1); + my $typemod = $3; + my $attr = $4; + + push @fields, $row->{field}; + my $info = $col_info{ $row->{field} }= { + TABLE_CAT => $catalog, + TABLE_SCHEM => $schema, + TABLE_NAME => $table, + COLUMN_NAME => $row->{field}, + NULLABLE => ($row->{null} eq 'YES') ? 1 : 0, + IS_NULLABLE => ($row->{null} eq 'YES') ? "YES" : "NO", + TYPE_NAME => uc($basetype), + COLUMN_DEF => $row->{default}, + ORDINAL_POSITION => ++$ordinal_pos, + mysql_is_pri_key => ($row->{key} eq 'PRI'), + mysql_type_name => $row->{type}, + mysql_is_auto_increment => ($row->{extra} =~ /auto_increment/i ? 1 : 0), + }; + # + # This code won't deal with a pathological case where a value + # contains a single quote followed by a comma, and doesn't unescape + # any escaped values. But who would use those in an enum or set? + # + my @type_params= ($typemod && index($typemod,"'")>=0) ? + ("$typemod," =~ /'(.*?)',/g) # assume all are quoted + : split /,/, $typemod||''; # no quotes, plain list + s/''/'/g for @type_params; # undo doubling of quotes + + my @type_attr= split / /, $attr||''; + + $info->{DATA_TYPE}= SQL_VARCHAR(); + if ($basetype =~ /^(char|varchar|\w*text|\w*blob)/) + { + $info->{DATA_TYPE}= SQL_CHAR() if $basetype eq 'char'; + if ($type_params[0]) + { + $info->{COLUMN_SIZE} = $type_params[0]; + } + else + { + $info->{COLUMN_SIZE} = 65535; + $info->{COLUMN_SIZE} = 255 if $basetype =~ /^tiny/; + $info->{COLUMN_SIZE} = 16777215 if $basetype =~ /^medium/; + $info->{COLUMN_SIZE} = 4294967295 if $basetype =~ /^long/; + } + } + elsif ($basetype =~ /^(binary|varbinary)/) + { + $info->{COLUMN_SIZE} = $type_params[0]; + # SQL_BINARY & SQL_VARBINARY are tempting here but don't match the + # semantics for mysql (not hex). SQL_CHAR & SQL_VARCHAR are correct here. + $info->{DATA_TYPE} = ($basetype eq 'binary') ? SQL_CHAR() : SQL_VARCHAR(); + } + elsif ($basetype =~ /^(enum|set)/) + { + if ($basetype eq 'set') + { + $info->{COLUMN_SIZE} = length(join ",", @type_params); + } + else + { + my $max_len = 0; + length($_) > $max_len and $max_len = length($_) for @type_params; + $info->{COLUMN_SIZE} = $max_len; + } + $info->{"mysql_values"} = \@type_params; + } + elsif ($basetype =~ /int/ || $basetype eq 'bit' ) + { + # big/medium/small/tiny etc + unsigned? + $info->{DATA_TYPE} = SQL_INTEGER(); + $info->{NUM_PREC_RADIX} = 10; + $info->{COLUMN_SIZE} = $type_params[0]; + } + elsif ($basetype =~ /^decimal/) + { + $info->{DATA_TYPE} = SQL_DECIMAL(); + $info->{NUM_PREC_RADIX} = 10; + $info->{COLUMN_SIZE} = $type_params[0]; + $info->{DECIMAL_DIGITS} = $type_params[1]; + } + elsif ($basetype =~ /^(float|double)/) + { + $info->{DATA_TYPE} = ($basetype eq 'float') ? SQL_FLOAT() : SQL_DOUBLE(); + $info->{NUM_PREC_RADIX} = 2; + $info->{COLUMN_SIZE} = ($basetype eq 'float') ? 32 : 64; + } + elsif ($basetype =~ /date|time/) + { + # date/datetime/time/timestamp + if ($basetype eq 'time' or $basetype eq 'date') + { + #$info->{DATA_TYPE} = ($basetype eq 'time') ? SQL_TYPE_TIME() : SQL_TYPE_DATE(); + $info->{DATA_TYPE} = ($basetype eq 'time') ? SQL_TIME() : SQL_DATE(); + $info->{COLUMN_SIZE} = ($basetype eq 'time') ? 8 : 10; + } + else + { + # datetime/timestamp + #$info->{DATA_TYPE} = SQL_TYPE_TIMESTAMP(); + $info->{DATA_TYPE} = SQL_TIMESTAMP(); + $info->{SQL_DATA_TYPE} = SQL_DATETIME(); + $info->{SQL_DATETIME_SUB} = $info->{DATA_TYPE} - ($info->{SQL_DATA_TYPE} * 10); + $info->{COLUMN_SIZE} = ($basetype eq 'datetime') ? 19 : $type_params[0] || 14; + } + $info->{DECIMAL_DIGITS}= 0; # no fractional seconds + } + elsif ($basetype eq 'year') + { + # no close standard so treat as int + $info->{DATA_TYPE} = SQL_INTEGER(); + $info->{NUM_PREC_RADIX} = 10; + $info->{COLUMN_SIZE} = 4; + } + else + { + Carp::carp("column_info: unrecognized column type '$basetype' of $table_id.$row->{field} treated as varchar"); + } + $info->{SQL_DATA_TYPE} ||= $info->{DATA_TYPE}; + #warn Dumper($info); + } + + my $sponge = DBI->connect("DBI:Sponge:", '','') + or ( $dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr")); + + my $sth = $sponge->prepare("column_info $table", { + rows => [ map { [ @{$_}{@names} ] } map { $col_info{$_} } @fields ], + NUM_OF_FIELDS => scalar @names, + NAME => \@names, + }) or + return ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); + + $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; + return $sth; +} + + +sub primary_key_info { + my ($dbh, $catalog, $schema, $table) = @_; + + return unless $dbh->func('_async_check'); + + $dbh->{mysql_server_prepare}||= 0; + my $mysql_server_prepare_save= $dbh->{mysql_server_prepare}; + + my $table_id = $dbh->quote_identifier($catalog, $schema, $table); + + my @names = qw( + TABLE_CAT TABLE_SCHEM TABLE_NAME COLUMN_NAME KEY_SEQ PK_NAME + ); + my %col_info; + + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + my $desc_sth = $dbh->prepare("SHOW KEYS FROM $table_id"); + my $desc= $dbh->selectall_arrayref($desc_sth, { Columns=>{} }); + my $ordinal_pos = 0; + for my $row (grep { $_->{key_name} eq 'PRIMARY'} @$desc) + { + $col_info{ $row->{column_name} }= { + TABLE_CAT => $catalog, + TABLE_SCHEM => $schema, + TABLE_NAME => $table, + COLUMN_NAME => $row->{column_name}, + KEY_SEQ => $row->{seq_in_index}, + PK_NAME => $row->{key_name}, + }; + } + + my $sponge = DBI->connect("DBI:Sponge:", '','') + or + ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr")); + + my $sth= $sponge->prepare("primary_key_info $table", { + rows => [ + map { [ @{$_}{@names} ] } + sort { $a->{KEY_SEQ} <=> $b->{KEY_SEQ} } + values %col_info + ], + NUM_OF_FIELDS => scalar @names, + NAME => \@names, + }) or + ($dbh->{mysql_server_prepare}= $mysql_server_prepare_save && + return $dbh->DBI::set_err($sponge->err(), $sponge->errstr())); + + $dbh->{mysql_server_prepare}= $mysql_server_prepare_save; + + return $sth; +} + + +sub foreign_key_info { + my ($dbh, + $pk_catalog, $pk_schema, $pk_table, + $fk_catalog, $fk_schema, $fk_table, + ) = @_; + + return unless $dbh->func('_async_check'); + + # INFORMATION_SCHEMA.KEY_COLUMN_USAGE was added in 5.0.6 + # no one is going to be running 5.0.6, taking out the check for $point > .6 + my ($maj, $min, $point) = _version($dbh); + return if $maj < 5 ; + + my $sql = <<'EOF'; +SELECT NULL AS PKTABLE_CAT, + A.REFERENCED_TABLE_SCHEMA AS PKTABLE_SCHEM, + A.REFERENCED_TABLE_NAME AS PKTABLE_NAME, + A.REFERENCED_COLUMN_NAME AS PKCOLUMN_NAME, + A.TABLE_CATALOG AS FKTABLE_CAT, + A.TABLE_SCHEMA AS FKTABLE_SCHEM, + A.TABLE_NAME AS FKTABLE_NAME, + A.COLUMN_NAME AS FKCOLUMN_NAME, + A.ORDINAL_POSITION AS KEY_SEQ, + NULL AS UPDATE_RULE, + NULL AS DELETE_RULE, + A.CONSTRAINT_NAME AS FK_NAME, + NULL AS PK_NAME, + NULL AS DEFERABILITY, + NULL AS UNIQUE_OR_PRIMARY + FROM INFORMATION_SCHEMA.KEY_COLUMN_USAGE A, + INFORMATION_SCHEMA.TABLE_CONSTRAINTS B + WHERE A.TABLE_SCHEMA = B.TABLE_SCHEMA AND A.TABLE_NAME = B.TABLE_NAME + AND A.CONSTRAINT_NAME = B.CONSTRAINT_NAME AND B.CONSTRAINT_TYPE IS NOT NULL +EOF + + my @where; + my @bind; + + # catalogs are not yet supported by MySQL + +# if (defined $pk_catalog) { +# push @where, 'A.REFERENCED_TABLE_CATALOG = ?'; +# push @bind, $pk_catalog; +# } + + if (defined $pk_schema) { + push @where, 'A.REFERENCED_TABLE_SCHEMA = ?'; + push @bind, $pk_schema; + } + + if (defined $pk_table) { + push @where, 'A.REFERENCED_TABLE_NAME = ?'; + push @bind, $pk_table; + } + +# if (defined $fk_catalog) { +# push @where, 'A.TABLE_CATALOG = ?'; +# push @bind, $fk_schema; +# } + + if (defined $fk_schema) { + push @where, 'A.TABLE_SCHEMA = ?'; + push @bind, $fk_schema; + } + + if (defined $fk_table) { + push @where, 'A.TABLE_NAME = ?'; + push @bind, $fk_table; + } + + if (@where) { + $sql .= ' AND '; + $sql .= join ' AND ', @where; + } + $sql .= " ORDER BY A.TABLE_SCHEMA, A.TABLE_NAME, A.ORDINAL_POSITION"; + + local $dbh->{FetchHashKeyName} = 'NAME_uc'; + my $sth = $dbh->prepare($sql); + $sth->execute(@bind); + + return $sth; +} +# #86030: PATCH: adding statistics_info support +# Thank you to David Dick http://search.cpan.org/~ddick/ +sub statistics_info { + my ($dbh, + $catalog, $schema, $table, + $unique_only, $quick, + ) = @_; + + return unless $dbh->func('_async_check'); + + # INFORMATION_SCHEMA.KEY_COLUMN_USAGE was added in 5.0.6 + # no one is going to be running 5.0.6, taking out the check for $point > .6 + my ($maj, $min, $point) = _version($dbh); + return if $maj < 5 ; + + my $sql = <<'EOF'; +SELECT TABLE_CATALOG AS TABLE_CAT, + TABLE_SCHEMA AS TABLE_SCHEM, + TABLE_NAME AS TABLE_NAME, + NON_UNIQUE AS NON_UNIQUE, + NULL AS INDEX_QUALIFIER, + INDEX_NAME AS INDEX_NAME, + LCASE(INDEX_TYPE) AS TYPE, + SEQ_IN_INDEX AS ORDINAL_POSITION, + COLUMN_NAME AS COLUMN_NAME, + COLLATION AS ASC_OR_DESC, + CARDINALITY AS CARDINALITY, + NULL AS PAGES, + NULL AS FILTER_CONDITION + FROM INFORMATION_SCHEMA.STATISTICS +EOF + + my @where; + my @bind; + + # catalogs are not yet supported by MySQL + +# if (defined $catalog) { +# push @where, 'TABLE_CATALOG = ?'; +# push @bind, $catalog; +# } + + if (defined $schema) { + push @where, 'TABLE_SCHEMA = ?'; + push @bind, $schema; + } + + if (defined $table) { + push @where, 'TABLE_NAME = ?'; + push @bind, $table; + } + + if (@where) { + $sql .= ' WHERE '; + $sql .= join ' AND ', @where; + } + $sql .= " ORDER BY TABLE_SCHEMA, TABLE_NAME, ORDINAL_POSITION"; + + local $dbh->{FetchHashKeyName} = 'NAME_uc'; + my $sth = $dbh->prepare($sql); + $sth->execute(@bind); + + return $sth; +} + +sub _version { + my $dbh = shift; + + return + $dbh->get_info($DBI::Const::GetInfoType::GetInfoType{SQL_DBMS_VER}) + =~ /(\d+)\.(\d+)\.(\d+)/; +} + + +#################### +# get_info() +# Generated by DBI::DBD::Metadata + +sub get_info { + my($dbh, $info_type) = @_; + + return unless $dbh->func('_async_check'); + require DBD::mysql::GetInfo; + my $v = $DBD::mysql::GetInfo::info{int($info_type)}; + $v = $v->($dbh) if ref $v eq 'CODE'; + return $v; +} + +BEGIN { + my @needs_async_check = qw/data_sources quote_identifier begin_work/; + + foreach my $method (@needs_async_check) { + no strict 'refs'; + + my $super = "SUPER::$method"; + *$method = sub { + my $h = shift; + return unless $h->func('_async_check'); + return $h->$super(@_); + }; + } +} + + +package DBD::mysql::st; # ====== STATEMENT ====== +use strict; + +BEGIN { + my @needs_async_result = qw/fetchrow_hashref fetchall_hashref/; + my @needs_async_check = qw/bind_param_array bind_col bind_columns execute_for_fetch/; + + foreach my $method (@needs_async_result) { + no strict 'refs'; + + my $super = "SUPER::$method"; + *$method = sub { + my $sth = shift; + if(defined $sth->mysql_async_ready) { + return unless $sth->mysql_async_result; + } + return $sth->$super(@_); + }; + } + + foreach my $method (@needs_async_check) { + no strict 'refs'; + + my $super = "SUPER::$method"; + *$method = sub { + my $h = shift; + return unless $h->func('_async_check'); + return $h->$super(@_); + }; + } +} + +1; + +__END__ + +#line 2084 diff --git a/apps/lib/DBD/mysql/GetInfo.pm b/apps/lib/DBD/mysql/GetInfo.pm new file mode 100644 index 0000000..ff817a1 --- /dev/null +++ b/apps/lib/DBD/mysql/GetInfo.pm @@ -0,0 +1,310 @@ +#line 1 "DBD/mysql/GetInfo.pm" +package DBD::mysql::GetInfo; +######################################## +# DBD::mysql::GetInfo +# +# +# Generated by DBI::DBD::Metadata +# $Author$ <-- the person to blame +# $Revision$ +# $Date$ + +use strict; +use warnings; + +use DBD::mysql; +# Beware: not officially documented interfaces... +# use DBI::Const::GetInfoType qw(%GetInfoType); +# use DBI::Const::GetInfoReturn qw(%GetInfoReturnTypes %GetInfoReturnValues); + +my $sql_driver = 'mysql'; + +# SQL_DRIVER_VER should be formatted as dd.dd.dddd +my $dbdversion = $DBD::mysql::VERSION; +$dbdversion .= '_00' if $dbdversion =~ /^\d+\.\d+$/; +my $sql_driver_ver = sprintf("%02d.%02d.%04d", split(/[\._]/,$dbdversion)); + + +my @Keywords = qw( + +BIGINT +BLOB +DEFAULT +KEYS +LIMIT +LONGBLOB +MEDIMUMBLOB +MEDIUMINT +MEDIUMTEXT +PROCEDURE +REGEXP +RLIKE +SHOW +TABLES +TINYBLOB +TINYTEXT +UNIQUE +UNSIGNED +ZEROFILL +); + + +sub sql_keywords { + + return join ',', @Keywords; + +} + + + +sub sql_data_source_name { + my $dbh = shift; + return "dbi:$sql_driver:" . $dbh->{Name}; +} + +sub sql_user_name { + my $dbh = shift; + # Non-standard attribute + return $dbh->{CURRENT_USER}; +} + + +#################### +# makefunc() +# returns a ref to a sub that calls into XS to get +# values for info types that must needs be coded in C + +sub makefunk ($) { + my $type = shift; + return sub {dbd_mysql_get_info(shift, $type)} +} + + + + +our %info = ( + 20 => 'N', # SQL_ACCESSIBLE_PROCEDURES + 19 => 'Y', # SQL_ACCESSIBLE_TABLES + 0 => 0, # SQL_ACTIVE_CONNECTIONS + 116 => 0, # SQL_ACTIVE_ENVIRONMENTS + 1 => 0, # SQL_ACTIVE_STATEMENTS + 169 => 127, # SQL_AGGREGATE_FUNCTIONS + 117 => 0, # SQL_ALTER_DOMAIN + 86 => 3, # SQL_ALTER_TABLE + 10021 => makefunk 10021, # SQL_ASYNC_MODE + 120 => 2, # SQL_BATCH_ROW_COUNT + 121 => 2, # SQL_BATCH_SUPPORT + 82 => 0, # SQL_BOOKMARK_PERSISTENCE + 114 => 1, # SQL_CATALOG_LOCATION + 10003 => 'Y', # SQL_CATALOG_NAME + 41 => makefunk 41, # SQL_CATALOG_NAME_SEPARATOR + 42 => makefunk 42, # SQL_CATALOG_TERM + 92 => 29, # SQL_CATALOG_USAGE + 10004 => '', # SQL_COLLATING_SEQUENCE + 10004 => '', # SQL_COLLATION_SEQ + 87 => 'Y', # SQL_COLUMN_ALIAS + 22 => 0, # SQL_CONCAT_NULL_BEHAVIOR + 53 => 259071, # SQL_CONVERT_BIGINT + 54 => 0, # SQL_CONVERT_BINARY + 55 => 259071, # SQL_CONVERT_BIT + 56 => 259071, # SQL_CONVERT_CHAR + 57 => 259071, # SQL_CONVERT_DATE + 58 => 259071, # SQL_CONVERT_DECIMAL + 59 => 259071, # SQL_CONVERT_DOUBLE + 60 => 259071, # SQL_CONVERT_FLOAT + 48 => 0, # SQL_CONVERT_FUNCTIONS +# 173 => undef, # SQL_CONVERT_GUID + 61 => 259071, # SQL_CONVERT_INTEGER + 123 => 0, # SQL_CONVERT_INTERVAL_DAY_TIME + 124 => 0, # SQL_CONVERT_INTERVAL_YEAR_MONTH + 71 => 0, # SQL_CONVERT_LONGVARBINARY + 62 => 259071, # SQL_CONVERT_LONGVARCHAR + 63 => 259071, # SQL_CONVERT_NUMERIC + 64 => 259071, # SQL_CONVERT_REAL + 65 => 259071, # SQL_CONVERT_SMALLINT + 66 => 259071, # SQL_CONVERT_TIME + 67 => 259071, # SQL_CONVERT_TIMESTAMP + 68 => 259071, # SQL_CONVERT_TINYINT + 69 => 0, # SQL_CONVERT_VARBINARY + 70 => 259071, # SQL_CONVERT_VARCHAR + 122 => 0, # SQL_CONVERT_WCHAR + 125 => 0, # SQL_CONVERT_WLONGVARCHAR + 126 => 0, # SQL_CONVERT_WVARCHAR + 74 => 1, # SQL_CORRELATION_NAME + 127 => 0, # SQL_CREATE_ASSERTION + 128 => 0, # SQL_CREATE_CHARACTER_SET + 129 => 0, # SQL_CREATE_COLLATION + 130 => 0, # SQL_CREATE_DOMAIN + 131 => 0, # SQL_CREATE_SCHEMA + 132 => 1045, # SQL_CREATE_TABLE + 133 => 0, # SQL_CREATE_TRANSLATION + 134 => 0, # SQL_CREATE_VIEW + 23 => 2, # SQL_CURSOR_COMMIT_BEHAVIOR + 24 => 2, # SQL_CURSOR_ROLLBACK_BEHAVIOR + 10001 => 0, # SQL_CURSOR_SENSITIVITY + 2 => \&sql_data_source_name, # SQL_DATA_SOURCE_NAME + 25 => 'N', # SQL_DATA_SOURCE_READ_ONLY + 119 => 7, # SQL_DATETIME_LITERALS + 17 => 'MySQL', # SQL_DBMS_NAME + 18 => makefunk 18, # SQL_DBMS_VER + 170 => 3, # SQL_DDL_INDEX + 26 => 2, # SQL_DEFAULT_TRANSACTION_ISOLATION + 26 => 2, # SQL_DEFAULT_TXN_ISOLATION + 10002 => 'N', # SQL_DESCRIBE_PARAMETER +# 171 => undef, # SQL_DM_VER + 3 => 137076632, # SQL_DRIVER_HDBC +# 135 => undef, # SQL_DRIVER_HDESC + 4 => 137076088, # SQL_DRIVER_HENV +# 76 => undef, # SQL_DRIVER_HLIB +# 5 => undef, # SQL_DRIVER_HSTMT + 6 => 'libmyodbc3.so', # SQL_DRIVER_NAME + 77 => '03.51', # SQL_DRIVER_ODBC_VER + 7 => $sql_driver_ver, # SQL_DRIVER_VER + 136 => 0, # SQL_DROP_ASSERTION + 137 => 0, # SQL_DROP_CHARACTER_SET + 138 => 0, # SQL_DROP_COLLATION + 139 => 0, # SQL_DROP_DOMAIN + 140 => 0, # SQL_DROP_SCHEMA + 141 => 7, # SQL_DROP_TABLE + 142 => 0, # SQL_DROP_TRANSLATION + 143 => 0, # SQL_DROP_VIEW + 144 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES1 + 145 => 0, # SQL_DYNAMIC_CURSOR_ATTRIBUTES2 + 27 => 'Y', # SQL_EXPRESSIONS_IN_ORDERBY + 8 => 63, # SQL_FETCH_DIRECTION + 84 => 0, # SQL_FILE_USAGE + 146 => 97863, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 + 147 => 6016, # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 + 81 => 11, # SQL_GETDATA_EXTENSIONS + 88 => 3, # SQL_GROUP_BY + 28 => 4, # SQL_IDENTIFIER_CASE + #29 => sub {dbd_mysql_get_info(shift,$GetInfoType {SQL_IDENTIFIER_QUOTE_CHAR})}, + 29 => makefunk 29, # SQL_IDENTIFIER_QUOTE_CHAR + 148 => 0, # SQL_INDEX_KEYWORDS + 149 => 0, # SQL_INFO_SCHEMA_VIEWS + 172 => 7, # SQL_INSERT_STATEMENT + 73 => 'N', # SQL_INTEGRITY + 150 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES1 + 151 => 0, # SQL_KEYSET_CURSOR_ATTRIBUTES2 + 89 => \&sql_keywords, # SQL_KEYWORDS + 113 => 'Y', # SQL_LIKE_ESCAPE_CLAUSE + 78 => 0, # SQL_LOCK_TYPES + 34 => 64, # SQL_MAXIMUM_CATALOG_NAME_LENGTH + 97 => 0, # SQL_MAXIMUM_COLUMNS_IN_GROUP_BY + 98 => 32, # SQL_MAXIMUM_COLUMNS_IN_INDEX + 99 => 0, # SQL_MAXIMUM_COLUMNS_IN_ORDER_BY + 100 => 0, # SQL_MAXIMUM_COLUMNS_IN_SELECT + 101 => 0, # SQL_MAXIMUM_COLUMNS_IN_TABLE + 30 => 64, # SQL_MAXIMUM_COLUMN_NAME_LENGTH + 1 => 0, # SQL_MAXIMUM_CONCURRENT_ACTIVITIES + 31 => 18, # SQL_MAXIMUM_CURSOR_NAME_LENGTH + 0 => 0, # SQL_MAXIMUM_DRIVER_CONNECTIONS + 10005 => 64, # SQL_MAXIMUM_IDENTIFIER_LENGTH + 102 => 500, # SQL_MAXIMUM_INDEX_SIZE + 104 => 0, # SQL_MAXIMUM_ROW_SIZE + 32 => 0, # SQL_MAXIMUM_SCHEMA_NAME_LENGTH + 105 => makefunk 105, # SQL_MAXIMUM_STATEMENT_LENGTH +# 20000 => undef, # SQL_MAXIMUM_STMT_OCTETS +# 20001 => undef, # SQL_MAXIMUM_STMT_OCTETS_DATA +# 20002 => undef, # SQL_MAXIMUM_STMT_OCTETS_SCHEMA + 106 => makefunk 106, # SQL_MAXIMUM_TABLES_IN_SELECT + 35 => 64, # SQL_MAXIMUM_TABLE_NAME_LENGTH + 107 => 16, # SQL_MAXIMUM_USER_NAME_LENGTH + 10022 => makefunk 10022, # SQL_MAX_ASYNC_CONCURRENT_STATEMENTS + 112 => 0, # SQL_MAX_BINARY_LITERAL_LEN + 34 => 64, # SQL_MAX_CATALOG_NAME_LEN + 108 => 0, # SQL_MAX_CHAR_LITERAL_LEN + 97 => 0, # SQL_MAX_COLUMNS_IN_GROUP_BY + 98 => 32, # SQL_MAX_COLUMNS_IN_INDEX + 99 => 0, # SQL_MAX_COLUMNS_IN_ORDER_BY + 100 => 0, # SQL_MAX_COLUMNS_IN_SELECT + 101 => 0, # SQL_MAX_COLUMNS_IN_TABLE + 30 => 64, # SQL_MAX_COLUMN_NAME_LEN + 1 => 0, # SQL_MAX_CONCURRENT_ACTIVITIES + 31 => 18, # SQL_MAX_CURSOR_NAME_LEN + 0 => 0, # SQL_MAX_DRIVER_CONNECTIONS + 10005 => 64, # SQL_MAX_IDENTIFIER_LEN + 102 => 500, # SQL_MAX_INDEX_SIZE + 32 => 0, # SQL_MAX_OWNER_NAME_LEN + 33 => 0, # SQL_MAX_PROCEDURE_NAME_LEN + 34 => 64, # SQL_MAX_QUALIFIER_NAME_LEN + 104 => 0, # SQL_MAX_ROW_SIZE + 103 => 'Y', # SQL_MAX_ROW_SIZE_INCLUDES_LONG + 32 => 0, # SQL_MAX_SCHEMA_NAME_LEN + 105 => 8192, # SQL_MAX_STATEMENT_LEN + 106 => 31, # SQL_MAX_TABLES_IN_SELECT + 35 => makefunk 35, # SQL_MAX_TABLE_NAME_LEN + 107 => 16, # SQL_MAX_USER_NAME_LEN + 37 => 'Y', # SQL_MULTIPLE_ACTIVE_TXN + 36 => 'Y', # SQL_MULT_RESULT_SETS + 111 => 'N', # SQL_NEED_LONG_DATA_LEN + 75 => 1, # SQL_NON_NULLABLE_COLUMNS + 85 => 2, # SQL_NULL_COLLATION + 49 => 16777215, # SQL_NUMERIC_FUNCTIONS + 9 => 1, # SQL_ODBC_API_CONFORMANCE + 152 => 2, # SQL_ODBC_INTERFACE_CONFORMANCE + 12 => 1, # SQL_ODBC_SAG_CLI_CONFORMANCE + 15 => 1, # SQL_ODBC_SQL_CONFORMANCE + 73 => 'N', # SQL_ODBC_SQL_OPT_IEF + 10 => '03.80', # SQL_ODBC_VER + 115 => 123, # SQL_OJ_CAPABILITIES + 90 => 'Y', # SQL_ORDER_BY_COLUMNS_IN_SELECT + 38 => 'Y', # SQL_OUTER_JOINS + 115 => 123, # SQL_OUTER_JOIN_CAPABILITIES + 39 => '', # SQL_OWNER_TERM + 91 => 0, # SQL_OWNER_USAGE + 153 => 2, # SQL_PARAM_ARRAY_ROW_COUNTS + 154 => 3, # SQL_PARAM_ARRAY_SELECTS + 80 => 3, # SQL_POSITIONED_STATEMENTS + 79 => 31, # SQL_POS_OPERATIONS + 21 => 'N', # SQL_PROCEDURES + 40 => '', # SQL_PROCEDURE_TERM + 114 => 1, # SQL_QUALIFIER_LOCATION + 41 => '.', # SQL_QUALIFIER_NAME_SEPARATOR + 42 => 'database', # SQL_QUALIFIER_TERM + 92 => 29, # SQL_QUALIFIER_USAGE + 93 => 3, # SQL_QUOTED_IDENTIFIER_CASE + 11 => 'N', # SQL_ROW_UPDATES + 39 => '', # SQL_SCHEMA_TERM + 91 => 0, # SQL_SCHEMA_USAGE + 43 => 7, # SQL_SCROLL_CONCURRENCY + 44 => 17, # SQL_SCROLL_OPTIONS + 14 => '\\', # SQL_SEARCH_PATTERN_ESCAPE + 13 => makefunk 13, # SQL_SERVER_NAME + 94 => 'ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜáíóúñÑ', # SQL_SPECIAL_CHARACTERS + 155 => 7, # SQL_SQL92_DATETIME_FUNCTIONS + 156 => 0, # SQL_SQL92_FOREIGN_KEY_DELETE_RULE + 157 => 0, # SQL_SQL92_FOREIGN_KEY_UPDATE_RULE + 158 => 8160, # SQL_SQL92_GRANT + 159 => 0, # SQL_SQL92_NUMERIC_VALUE_FUNCTIONS + 160 => 0, # SQL_SQL92_PREDICATES + 161 => 466, # SQL_SQL92_RELATIONAL_JOIN_OPERATORS + 162 => 32640, # SQL_SQL92_REVOKE + 163 => 7, # SQL_SQL92_ROW_VALUE_CONSTRUCTOR + 164 => 255, # SQL_SQL92_STRING_FUNCTIONS + 165 => 0, # SQL_SQL92_VALUE_EXPRESSIONS + 118 => 4, # SQL_SQL_CONFORMANCE + 166 => 2, # SQL_STANDARD_CLI_CONFORMANCE + 167 => 97863, # SQL_STATIC_CURSOR_ATTRIBUTES1 + 168 => 6016, # SQL_STATIC_CURSOR_ATTRIBUTES2 + 83 => 7, # SQL_STATIC_SENSITIVITY + 50 => 491519, # SQL_STRING_FUNCTIONS + 95 => 0, # SQL_SUBQUERIES + 51 => 7, # SQL_SYSTEM_FUNCTIONS + 45 => 'table', # SQL_TABLE_TERM + 109 => 0, # SQL_TIMEDATE_ADD_INTERVALS + 110 => 0, # SQL_TIMEDATE_DIFF_INTERVALS + 52 => 106495, # SQL_TIMEDATE_FUNCTIONS + 46 => 3, # SQL_TRANSACTION_CAPABLE + 72 => 15, # SQL_TRANSACTION_ISOLATION_OPTION + 46 => 3, # SQL_TXN_CAPABLE + 72 => 15, # SQL_TXN_ISOLATION_OPTION + 96 => 0, # SQL_UNION + 96 => 0, # SQL_UNION_STATEMENT + 47 => \&sql_user_name, # SQL_USER_NAME + 10000 => 1992, # SQL_XOPEN_CLI_YEAR +); + +1; + +__END__ diff --git a/apps/lib/DBI.pm b/apps/lib/DBI.pm new file mode 100644 index 0000000..49a429b --- /dev/null +++ b/apps/lib/DBI.pm @@ -0,0 +1,2019 @@ +#line 1 "DBI.pm" +# $Id$ +# vim: ts=8:sw=4:et +# +# Copyright (c) 1994-2012 Tim Bunce Ireland +# +# See COPYRIGHT section in pod text below for usage and distribution rights. +# + +package DBI; + +require 5.008_001; + +BEGIN { +our $XS_VERSION = our $VERSION = "1.636"; # ==> ALSO update the version in the pod text below! +$VERSION = eval $VERSION; +} + +#line 174 + +# The POD text continues at the end of the file. + +use Carp(); +use DynaLoader (); +use Exporter (); + +BEGIN { +@ISA = qw(Exporter DynaLoader); + +# Make some utility functions available if asked for +@EXPORT = (); # we export nothing by default +@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags: +%EXPORT_TAGS = ( + sql_types => [ qw( + SQL_GUID + SQL_WLONGVARCHAR + SQL_WVARCHAR + SQL_WCHAR + SQL_BIGINT + SQL_BIT + SQL_TINYINT + SQL_LONGVARBINARY + SQL_VARBINARY + SQL_BINARY + SQL_LONGVARCHAR + SQL_UNKNOWN_TYPE + SQL_ALL_TYPES + SQL_CHAR + SQL_NUMERIC + SQL_DECIMAL + SQL_INTEGER + SQL_SMALLINT + SQL_FLOAT + SQL_REAL + SQL_DOUBLE + SQL_DATETIME + SQL_DATE + SQL_INTERVAL + SQL_TIME + SQL_TIMESTAMP + SQL_VARCHAR + SQL_BOOLEAN + SQL_UDT + SQL_UDT_LOCATOR + SQL_ROW + SQL_REF + SQL_BLOB + SQL_BLOB_LOCATOR + SQL_CLOB + SQL_CLOB_LOCATOR + SQL_ARRAY + SQL_ARRAY_LOCATOR + SQL_MULTISET + SQL_MULTISET_LOCATOR + SQL_TYPE_DATE + SQL_TYPE_TIME + SQL_TYPE_TIMESTAMP + SQL_TYPE_TIME_WITH_TIMEZONE + SQL_TYPE_TIMESTAMP_WITH_TIMEZONE + SQL_INTERVAL_YEAR + SQL_INTERVAL_MONTH + SQL_INTERVAL_DAY + SQL_INTERVAL_HOUR + SQL_INTERVAL_MINUTE + SQL_INTERVAL_SECOND + SQL_INTERVAL_YEAR_TO_MONTH + SQL_INTERVAL_DAY_TO_HOUR + SQL_INTERVAL_DAY_TO_MINUTE + SQL_INTERVAL_DAY_TO_SECOND + SQL_INTERVAL_HOUR_TO_MINUTE + SQL_INTERVAL_HOUR_TO_SECOND + SQL_INTERVAL_MINUTE_TO_SECOND + ) ], + sql_cursor_types => [ qw( + SQL_CURSOR_FORWARD_ONLY + SQL_CURSOR_KEYSET_DRIVEN + SQL_CURSOR_DYNAMIC + SQL_CURSOR_STATIC + SQL_CURSOR_TYPE_DEFAULT + ) ], # for ODBC cursor types + utils => [ qw( + neat neat_list $neat_maxlen dump_results looks_like_number + data_string_diff data_string_desc data_diff sql_type_cast + DBIstcf_DISCARD_STRING + DBIstcf_STRICT + ) ], + profile => [ qw( + dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time + ) ], # notionally "in" DBI::Profile and normally imported from there +); + +$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields +$DBI::neat_maxlen = 1000; +$DBI::stderr = 2_000_000_000; # a very round number below 2**31 + +# If you get an error here like "Can't find loadable object ..." +# then you haven't installed the DBI correctly. Read the README +# then install it again. +if ( $ENV{DBI_PUREPERL} ) { + eval { bootstrap DBI $XS_VERSION } if $ENV{DBI_PUREPERL} == 1; + require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2; + $DBI::PurePerl ||= 0; # just to silence "only used once" warnings +} +else { + bootstrap DBI $XS_VERSION; +} + +$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %{__PACKAGE__."::"} ]; + +Exporter::export_ok_tags(keys %EXPORT_TAGS); + +} + +# Alias some handle methods to also be DBI class methods +for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) { + no strict; + *$_ = \&{"DBD::_::common::$_"}; +} + +use strict; + +DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE}; + +$DBI::connect_via ||= "connect"; + +# check if user wants a persistent database connection ( Apache + mod_perl ) +if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) { + $DBI::connect_via = "Apache::DBI::connect"; + DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n"); +} + +# check for weaken support, used by ChildHandles +my $HAS_WEAKEN = eval { + require Scalar::Util; + # this will croak() if this Scalar::Util doesn't have a working weaken(). + Scalar::Util::weaken( \my $test ); # same test as in t/72childhandles.t + 1; +}; + +%DBI::installed_drh = (); # maps driver names to installed driver handles +sub installed_drivers { %DBI::installed_drh } +%DBI::installed_methods = (); # XXX undocumented, may change +sub installed_methods { %DBI::installed_methods } + +# Setup special DBI dynamic variables. See DBI::var::FETCH for details. +# These are dynamically associated with the last handle used. +tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list +tie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list +tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean +tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg +tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg +sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; } +sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") } + +# --- Driver Specific Prefix Registry --- + +my $dbd_prefix_registry = { + ad_ => { class => 'DBD::AnyData', }, + ad2_ => { class => 'DBD::AnyData2', }, + ado_ => { class => 'DBD::ADO', }, + amzn_ => { class => 'DBD::Amazon', }, + best_ => { class => 'DBD::BestWins', }, + csv_ => { class => 'DBD::CSV', }, + cubrid_ => { class => 'DBD::cubrid', }, + db2_ => { class => 'DBD::DB2', }, + dbi_ => { class => 'DBI', }, + dbm_ => { class => 'DBD::DBM', }, + df_ => { class => 'DBD::DF', }, + examplep_ => { class => 'DBD::ExampleP', }, + f_ => { class => 'DBD::File', }, + file_ => { class => 'DBD::TextFile', }, + go_ => { class => 'DBD::Gofer', }, + ib_ => { class => 'DBD::InterBase', }, + ing_ => { class => 'DBD::Ingres', }, + ix_ => { class => 'DBD::Informix', }, + jdbc_ => { class => 'DBD::JDBC', }, + mo_ => { class => 'DBD::MO', }, + monetdb_ => { class => 'DBD::monetdb', }, + msql_ => { class => 'DBD::mSQL', }, + mvsftp_ => { class => 'DBD::MVS_FTPSQL', }, + mysql_ => { class => 'DBD::mysql', }, + multi_ => { class => 'DBD::Multi' }, + mx_ => { class => 'DBD::Multiplex', }, + neo_ => { class => 'DBD::Neo4p', }, + nullp_ => { class => 'DBD::NullP', }, + odbc_ => { class => 'DBD::ODBC', }, + ora_ => { class => 'DBD::Oracle', }, + pg_ => { class => 'DBD::Pg', }, + pgpp_ => { class => 'DBD::PgPP', }, + plb_ => { class => 'DBD::Plibdata', }, + po_ => { class => 'DBD::PO', }, + proxy_ => { class => 'DBD::Proxy', }, + ram_ => { class => 'DBD::RAM', }, + rdb_ => { class => 'DBD::RDB', }, + sapdb_ => { class => 'DBD::SAP_DB', }, + snmp_ => { class => 'DBD::SNMP', }, + solid_ => { class => 'DBD::Solid', }, + spatialite_ => { class => 'DBD::Spatialite', }, + sponge_ => { class => 'DBD::Sponge', }, + sql_ => { class => 'DBI::DBD::SqlEngine', }, + sqlite_ => { class => 'DBD::SQLite', }, + syb_ => { class => 'DBD::Sybase', }, + sys_ => { class => 'DBD::Sys', }, + tdat_ => { class => 'DBD::Teradata', }, + tmpl_ => { class => 'DBD::Template', }, + tmplss_ => { class => 'DBD::TemplateSS', }, + tree_ => { class => 'DBD::TreeData', }, + tuber_ => { class => 'DBD::Tuber', }, + uni_ => { class => 'DBD::Unify', }, + vt_ => { class => 'DBD::Vt', }, + wmi_ => { class => 'DBD::WMI', }, + x_ => { }, # for private use + xbase_ => { class => 'DBD::XBase', }, + xl_ => { class => 'DBD::Excel', }, + yaswi_ => { class => 'DBD::Yaswi', }, +}; + +my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } } + grep { exists $dbd_prefix_registry->{$_}->{class} } + keys %{$dbd_prefix_registry}; + +sub dump_dbd_registry { + require Data::Dumper; + local $Data::Dumper::Sortkeys=1; + local $Data::Dumper::Indent=1; + print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]); +} + +# --- Dynamically create the DBI Standard Interface + +my $keeperr = { O=>0x0004 }; + +%DBI::DBI_methods = ( # Define the DBI interface methods per class: + + common => { # Interface methods common to all DBI handle classes + 'DESTROY' => { O=>0x004|0x10000 }, + 'CLEAR' => $keeperr, + 'EXISTS' => $keeperr, + 'FETCH' => { O=>0x0404 }, + 'FETCH_many' => { O=>0x0404 }, + 'FIRSTKEY' => $keeperr, + 'NEXTKEY' => $keeperr, + 'STORE' => { O=>0x0418 | 0x4 }, + 'DELETE' => { O=>0x0404 }, + can => { O=>0x0100 }, # special case, see dispatch + debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace + dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 }, + err => $keeperr, + errstr => $keeperr, + state => $keeperr, + func => { O=>0x0006 }, + parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 }, + parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 }, + private_data => { U =>[1,1], O=>0x0004 }, + set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 }, + trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 }, + trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 }, + swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] }, + private_attribute_info => { }, + visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 }, + }, + dr => { # Database Driver Interface + 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 }, + 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 }, + 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 }, + data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 }, + default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 }, + dbixs_revision => $keeperr, + }, + db => { # Database Session Class Interface + data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 }, + take_imp_data => { U =>[1,1], O=>0x10000 }, + clone => { U =>[1,2,'[\%attr]'], T=>0x200 }, + connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 }, + begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 }, + commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 }, + rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 }, + 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 }, + last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name, $field_name [, \%attr ]'], O=>0x2800 }, + preparse => { }, # XXX + prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 }, + prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 }, + selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_array =>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + ping => { U =>[1,1], O=>0x0404 }, + disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 }, + quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430, T=>2 }, + quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430, T=>2 }, + rows => $keeperr, + + tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 }, + table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 }, + column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 }, + primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 }, + primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 }, + foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 }, + statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 }, + type_info_all => { U =>[1,1], O=>0x2200|0x0800 }, + type_info => { U =>[1,2,'$data_type'], O=>0x2200 }, + get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 }, + }, + st => { # Statement Class Interface + bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] }, + bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] }, + bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] }, + bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] }, + execute => { U =>[1,0,'[@args]'], O=>0x1040 }, + + bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] }, + bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] }, + execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 }, + execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 }, + + fetch => undef, # alias for fetchrow_arrayref + fetchrow_arrayref => undef, + fetchrow_hashref => undef, + fetchrow_array => undef, + fetchrow => undef, # old alias for fetchrow_array + + fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] }, + fetchall_hashref => { U =>[2,2,'$key_field'] }, + + blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] }, + blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] }, + dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] }, + more_results => { U =>[1,1] }, + finish => { U =>[1,1] }, + cancel => { U =>[1,1], O=>0x0800 }, + rows => $keeperr, + + _get_fbav => undef, + _set_fbav => { T=>6 }, + }, +); + +while ( my ($class, $meths) = each %DBI::DBI_methods ) { + my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0); + while ( my ($method, $info) = each %$meths ) { + my $fullmeth = "DBI::${class}::$method"; + if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods + # and optionally filter by IMA flags + my $O = $info->{O}||0; + printf "0x%04x %-20s\n", $O, $fullmeth + unless $ima_trace && !($O & $ima_trace); + } + DBI->_install_method($fullmeth, 'DBI.pm', $info); + } +} + +{ + package DBI::common; + @DBI::dr::ISA = ('DBI::common'); + @DBI::db::ISA = ('DBI::common'); + @DBI::st::ISA = ('DBI::common'); +} + +# End of init code + + +END { + return unless defined &DBI::trace_msg; # return unless bootstrap'd ok + local ($!,$?); + DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2); + # Let drivers know why we are calling disconnect_all: + $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning + DBI->disconnect_all() if %DBI::installed_drh; +} + + +sub CLONE { + _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure + DBI->trace_msg("CLONE DBI for new thread\n"); + while ( my ($driver, $drh) = each %DBI::installed_drh) { + no strict 'refs'; + next if defined &{"DBD::${driver}::CLONE"}; + warn("$driver has no driver CLONE() function so is unsafe threaded\n"); + } + %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize +} + +sub parse_dsn { + my ($class, $dsn) = @_; + $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return; + my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3); + $driver ||= $ENV{DBI_DRIVER} || ''; + $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr; + return ($scheme, $driver, $attr, $attr_hash, $dsn); +} + +sub visit_handles { + my ($class, $code, $outer_info) = @_; + $outer_info = {} if not defined $outer_info; + my %drh = DBI->installed_drivers; + for my $h (values %drh) { + my $child_info = $code->($h, $outer_info) + or next; + $h->visit_child_handles($code, $child_info); + } + return $outer_info; +} + + +# --- The DBI->connect Front Door methods + +sub connect_cached { + # For library code using connect_cached() with mod_perl + # we redirect those calls to Apache::DBI::connect() as well + my ($class, $dsn, $user, $pass, $attr) = @_; + my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect") + ? 'Apache::DBI::connect' : 'connect_cached'; + $attr = { + $attr ? %$attr : (), # clone, don't modify callers data + dbi_connect_method => $dbi_connect_method, + }; + return $class->connect($dsn, $user, $pass, $attr); +} + +sub connect { + my $class = shift; + my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_; + my $driver; + + if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style + Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions"); + ($old_driver, $attr) = ($attr, $old_driver); + } + + my $connect_meth = $attr->{dbi_connect_method}; + $connect_meth ||= $DBI::connect_via; # fallback to default + + $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver; + + if ($DBI::dbi_debug) { + local $^W = 0; + pop @_ if $connect_meth ne 'connect'; + my @args = @_; $args[2] = '****'; # hide password + DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n"); + } + Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])') + if (ref $old_driver or ($attr and not ref $attr) or ref $pass); + + # extract dbi:driver prefix from $dsn into $1 + $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i + or '' =~ /()/; # ensure $1 etc are empty if match fails + my $driver_attrib_spec = $2 || ''; + + # Set $driver. Old style driver, if specified, overrides new dsn style. + $driver = $old_driver || $1 || $ENV{DBI_DRIVER} + or Carp::croak("Can't connect to data source '$dsn' " + ."because I can't work out what driver to use " + ."(it doesn't seem to contain a 'dbi:driver:' prefix " + ."and the DBI_DRIVER env var is not set)"); + + my $proxy; + if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') { + my $dbi_autoproxy = $ENV{DBI_AUTOPROXY}; + $proxy = 'Proxy'; + if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) { + $proxy = $1; + $driver_attrib_spec = join ",", + ($driver_attrib_spec) ? $driver_attrib_spec : (), + ($2 ) ? $2 : (); + } + $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn"; + $driver = $proxy; + DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n"); + } + # avoid recursion if proxy calls DBI->connect itself + local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; + + my %attributes; # take a copy we can delete from + if ($old_driver) { + %attributes = %$attr if $attr; + } + else { # new-style connect so new default semantics + %attributes = ( + PrintError => 1, + AutoCommit => 1, + ref $attr ? %$attr : (), + # attributes in DSN take precedence over \%attr connect parameter + $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (), + ); + } + $attr = \%attributes; # now set $attr to refer to our local copy + + my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver) + or die "panic: $class->install_driver($driver) failed"; + + # attributes in DSN take precedence over \%attr connect parameter + $user = $attr->{Username} if defined $attr->{Username}; + $pass = $attr->{Password} if defined $attr->{Password}; + delete $attr->{Password}; # always delete Password as closure stores it securely + if ( !(defined $user && defined $pass) ) { + ($user, $pass) = $drh->default_user($user, $pass, $attr); + } + $attr->{Username} = $user; # force the Username to be the actual one used + + my $connect_closure = sub { + my ($old_dbh, $override_attr) = @_; + + #use Data::Dumper; + #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]); + + my $dbh; + unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) { + $user = '' if !defined $user; + $dsn = '' if !defined $dsn; + # $drh->errstr isn't safe here because $dbh->DESTROY may not have + # been called yet and so the dbh errstr would not have been copied + # up to the drh errstr. Certainly true for connect_cached! + my $errstr = $DBI::errstr; + # Getting '(no error string)' here is a symptom of a ref loop + $errstr = '(no error string)' if !defined $errstr; + my $msg = "$class connect('$dsn','$user',...) failed: $errstr"; + DBI->trace_msg(" $msg\n"); + # XXX HandleWarn + unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) { + Carp::croak($msg) if $attr->{RaiseError}; + Carp::carp ($msg) if $attr->{PrintError}; + } + $! = 0; # for the daft people who do DBI->connect(...) || die "$!"; + return $dbh; # normally undef, but HandleError could change it + } + + # merge any attribute overrides but don't change $attr itself (for closure) + my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr }; + + # handle basic RootClass subclassing: + my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : ''); + if ($rebless_class) { + no strict 'refs'; + if ($apply->{RootClass}) { # explicit attribute (ie not static method call class) + delete $apply->{RootClass}; + DBI::_load_class($rebless_class, 0); + } + unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) { + Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored"); + $rebless_class = undef; + $class = 'DBI'; + } + else { + $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db + DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st' + DBI::_rebless($dbh, $rebless_class); # appends '::db' + } + } + + if (%$apply) { + + if ($apply->{DbTypeSubclass}) { + my $DbTypeSubclass = delete $apply->{DbTypeSubclass}; + DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass); + } + my $a; + foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first + next unless exists $apply->{$a}; + $dbh->{$a} = delete $apply->{$a}; + } + while ( my ($a, $v) = each %$apply) { + eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH + warn $@ if $@; + } + } + + # confirm to driver (ie if subclassed) that we've connected successfully + # and finished the attribute setup. pass in the original arguments + $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy; + + DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF; + + return $dbh; + }; + + my $dbh = &$connect_closure(undef, undef); + + $dbh->{dbi_connect_closure} = $connect_closure if $dbh; + + return $dbh; +} + + +sub disconnect_all { + keys %DBI::installed_drh; # reset iterator + while ( my ($name, $drh) = each %DBI::installed_drh ) { + $drh->disconnect_all() if ref $drh; + } +} + + +sub disconnect { # a regular beginners bug + Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)"); +} + + +sub install_driver { # croaks on failure + my $class = shift; + my($driver, $attr) = @_; + my $drh; + + $driver ||= $ENV{DBI_DRIVER} || ''; + + # allow driver to be specified as a 'dbi:driver:' string + $driver = $1 if $driver =~ s/^DBI:(.*?)://i; + + Carp::croak("usage: $class->install_driver(\$driver [, \%attr])") + unless ($driver and @_<=3); + + # already installed + return $drh if $drh = $DBI::installed_drh{$driver}; + + $class->trace_msg(" -> $class->install_driver($driver" + .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n") + if $DBI::dbi_debug & 0xF; + + # --- load the code + my $driver_class = "DBD::$driver"; + eval qq{package # hide from PAUSE + DBI::_firesafe; # just in case + require $driver_class; # load the driver + }; + if ($@) { + my $err = $@; + my $advice = ""; + if ($err =~ /Can't find loadable object/) { + $advice = "Perhaps DBD::$driver was statically linked into a new perl binary." + ."\nIn which case you need to use that new perl binary." + ."\nOr perhaps only the .pm file was installed but not the shared object file." + } + elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) { + my @drv = $class->available_drivers(1); + $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n" + ."or perhaps the capitalisation of '$driver' isn't right.\n" + ."Available drivers: ".join(", ", @drv)."."; + } + elsif ($err =~ /Can't load .*? for module DBD::/) { + $advice = "Perhaps a required shared library or dll isn't installed where expected"; + } + elsif ($err =~ /Can't locate .*? in \@INC/) { + $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed"; + } + Carp::croak("install_driver($driver) failed: $err$advice\n"); + } + if ($DBI::dbi_debug & 0xF) { + no strict 'refs'; + (my $driver_file = $driver_class) =~ s/::/\//g; + my $dbd_ver = ${"$driver_class\::VERSION"} || "undef"; + $class->trace_msg(" install_driver: $driver_class version $dbd_ver" + ." loaded from $INC{qq($driver_file.pm)}\n"); + } + + # --- do some behind-the-scenes checks and setups on the driver + $class->setup_driver($driver_class); + + # --- run the driver function + $drh = eval { $driver_class->driver($attr || {}) }; + unless ($drh && ref $drh && !$@) { + my $advice = ""; + $@ ||= "$driver_class->driver didn't return a handle"; + # catch people on case in-sensitive systems using the wrong case + $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right." + if $@ =~ /locate object method/; + Carp::croak("$driver_class initialisation failed: $@$advice"); + } + + $DBI::installed_drh{$driver} = $drh; + $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF; + $drh; +} + +*driver = \&install_driver; # currently an alias, may change + + +sub setup_driver { + my ($class, $driver_class) = @_; + my $h_type; + foreach $h_type (qw(dr db st)){ + my $h_class = $driver_class."::$h_type"; + no strict 'refs'; + push @{"${h_class}::ISA"}, "DBD::_::$h_type" + unless UNIVERSAL::isa($h_class, "DBD::_::$h_type"); + # The _mem class stuff is (IIRC) a crufty hack for global destruction + # timing issues in early versions of perl5 and possibly no longer needed. + my $mem_class = "DBD::_mem::$h_type"; + push @{"${h_class}_mem::ISA"}, $mem_class + unless UNIVERSAL::isa("${h_class}_mem", $mem_class) + or $DBI::PurePerl; + } +} + + +sub _rebless { + my $dbh = shift; + my ($outer, $inner) = DBI::_handles($dbh); + my $class = shift(@_).'::db'; + bless $inner => $class; + bless $outer => $class; # outer last for return +} + + +sub _set_isa { + my ($classes, $topclass) = @_; + my $trace = DBI->trace_msg(" _set_isa([@$classes])\n"); + foreach my $suffix ('::db','::st') { + my $previous = $topclass || 'DBI'; # trees are rooted here + foreach my $class (@$classes) { + my $base_class = $previous.$suffix; + my $sub_class = $class.$suffix; + my $sub_class_isa = "${sub_class}::ISA"; + no strict 'refs'; + if (@$sub_class_isa) { + DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n") + if $trace; + } + else { + @$sub_class_isa = ($base_class) unless @$sub_class_isa; + DBI->trace_msg(" $sub_class_isa = $base_class\n") + if $trace; + } + $previous = $class; + } + } +} + + +sub _rebless_dbtype_subclass { + my ($dbh, $rootclass, $DbTypeSubclass) = @_; + # determine the db type names for class hierarchy + my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass); + # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc) + $_ = $rootclass.'::'.$_ foreach (@hierarchy); + # load the modules from the 'top down' + DBI::_load_class($_, 1) foreach (reverse @hierarchy); + # setup class hierarchy if needed, does both '::db' and '::st' + DBI::_set_isa(\@hierarchy, $rootclass); + # finally bless the handle into the subclass + DBI::_rebless($dbh, $hierarchy[0]); +} + + +sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC + my ($dbh, $DbTypeSubclass) = @_; + + if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') { + # treat $DbTypeSubclass as a comma separated list of names + my @dbtypes = split /\s*,\s*/, $DbTypeSubclass; + $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n"); + return @dbtypes; + } + + # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future? + + my $driver = $dbh->{Driver}->{Name}; + if ( $driver eq 'Proxy' ) { + # XXX Looking into the internals of DBD::Proxy is questionable! + ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i + or die "Can't determine driver name from proxy"; + } + + my @dbtypes = (ucfirst($driver)); + if ($driver eq 'ODBC' || $driver eq 'ADO') { + # XXX will move these out and make extensible later: + my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar' + my %_dbtype_name_map = ( + 'Microsoft SQL Server' => 'MSSQL', + 'SQL Server' => 'Sybase', + 'Adaptive Server Anywhere' => 'ASAny', + 'ADABAS D' => 'AdabasD', + ); + + my $name; + $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME + if $driver eq 'ODBC'; + $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value + if $driver eq 'ADO'; + die "Can't determine driver name! ($DBI::errstr)\n" + unless $name; + + my $dbtype; + if ($_dbtype_name_map{$name}) { + $dbtype = $_dbtype_name_map{$name}; + } + else { + if ($name =~ /($_dbtype_name_regexp)/) { + $dbtype = lc($1); + } + else { # generic mangling for other names: + $dbtype = lc($name); + } + $dbtype =~ s/\b(\w)/\U$1/g; + $dbtype =~ s/\W+/_/g; + } + # add ODBC 'behind' ADO + push @dbtypes, 'ODBC' if $driver eq 'ADO'; + # add discovered dbtype in front of ADO/ODBC + unshift @dbtypes, $dbtype; + } + @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes) + if (ref $DbTypeSubclass eq 'CODE'); + $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n"); + return @dbtypes; +} + +sub _load_class { + my ($load_class, $missing_ok) = @_; + DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2); + no strict 'refs'; + return 1 if @{"$load_class\::ISA"}; # already loaded/exists + (my $module = $load_class) =~ s!::!/!g; + DBI->trace_msg(" _load_class require $module\n", 2); + eval { require "$module.pm"; }; + return 1 unless $@; + return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/; + die $@; +} + + +sub init_rootclass { # deprecated + return 1; +} + + +*internal = \&DBD::Switch::dr::driver; + +sub driver_prefix { + my ($class, $driver) = @_; + return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver}; + return; +} + +sub available_drivers { + my($quiet) = @_; + my(@drivers, $d, $f); + local(*DBI::DIR, $@); + my(%seen_dir, %seen_dbd); + my $haveFileSpec = eval { require File::Spec }; + foreach $d (@INC){ + chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness + my $dbd_dir = + ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD"); + next unless -d $dbd_dir; + next if $seen_dir{$d}; + $seen_dir{$d} = 1; + # XXX we have a problem here with case insensitive file systems + # XXX since we can't tell what case must be used when loading. + opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n"; + foreach $f (readdir(DBI::DIR)){ + next unless $f =~ s/\.pm$//; + next if $f eq 'NullP'; + if ($seen_dbd{$f}){ + Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n" + unless $quiet; + } else { + push(@drivers, $f); + } + $seen_dbd{$f} = $d; + } + closedir(DBI::DIR); + } + + # "return sort @drivers" will not DWIM in scalar context. + return wantarray ? sort @drivers : @drivers; +} + +sub installed_versions { + my ($class, $quiet) = @_; + my %error; + my %version; + for my $driver ($class->available_drivers($quiet)) { + next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC; + my $drh = eval { + local $SIG{__WARN__} = sub {}; + $class->install_driver($driver); + }; + ($error{"DBD::$driver"}=$@),next if $@; + no strict 'refs'; + my $vers = ${"DBD::$driver" . '::VERSION'}; + $version{"DBD::$driver"} = $vers || '?'; + } + if (wantarray) { + return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version; + } + $version{"DBI"} = $DBI::VERSION; + $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl; + if (!defined wantarray) { # void context + require Config; # add more detail + $version{OS} = "$^O\t($Config::Config{osvers})"; + $version{Perl} = "$]\t($Config::Config{archname})"; + $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_}) + for keys %error; + printf " %-16s: %s\n",$_,$version{$_} + for reverse sort keys %version; + } + return \%version; +} + + +sub data_sources { + my ($class, $driver, @other) = @_; + my $drh = $class->install_driver($driver); + my @ds = $drh->data_sources(@other); + return @ds; +} + + +sub neat_list { + my ($listref, $maxlen, $sep) = @_; + $maxlen = 0 unless defined $maxlen; # 0 == use internal default + $sep = ", " unless defined $sep; + join($sep, map { neat($_,$maxlen) } @$listref); +} + + +sub dump_results { # also aliased as a method in DBD::_::st + my ($sth, $maxlen, $lsep, $fsep, $fh) = @_; + return 0 unless $sth; + $maxlen ||= 35; + $lsep ||= "\n"; + $fh ||= \*STDOUT; + my $rows = 0; + my $ref; + while($ref = $sth->fetch) { + print $fh $lsep if $rows++ and $lsep; + my $str = neat_list($ref,$maxlen,$fsep); + print $fh $str; # done on two lines to avoid 5.003 errors + } + print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n"; + $rows; +} + + +sub data_diff { + my ($a, $b, $logical) = @_; + + my $diff = data_string_diff($a, $b); + return "" if $logical and !$diff; + + my $a_desc = data_string_desc($a); + my $b_desc = data_string_desc($b); + return "" if !$diff and $a_desc eq $b_desc; + + $diff ||= "Strings contain the same sequence of characters" + if length($a); + $diff .= "\n" if $diff; + return "a: $a_desc\nb: $b_desc\n$diff"; +} + + +sub data_string_diff { + # Compares 'logical' characters, not bytes, so a latin1 string and an + # an equivalent Unicode string will compare as equal even though their + # byte encodings are different. + my ($a, $b) = @_; + unless (defined $a and defined $b) { # one undef + return "" + if !defined $a and !defined $b; + return "String a is undef, string b has ".length($b)." characters" + if !defined $a; + return "String b is undef, string a has ".length($a)." characters" + if !defined $b; + } + + require utf8; + # hack to cater for perl 5.6 + *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8; + + my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a); + my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b); + my $i = 0; + while (@a_chars && @b_chars) { + ++$i, shift(@a_chars), shift(@b_chars), next + if $a_chars[0] == $b_chars[0];# compare ordinal values + my @desc = map { + $_ > 255 ? # if wide character... + sprintf("\\x{%04X}", $_) : # \x{...} + chr($_) =~ /[[:cntrl:]]/ ? # else if control character ... + sprintf("\\x%02X", $_) : # \x.. + chr($_) # else as themselves + } ($a_chars[0], $b_chars[0]); + # highlight probable double-encoding? + foreach my $c ( @desc ) { + next unless $c =~ m/\\x\{08(..)}/; + $c .= "='" .chr(hex($1)) ."'" + } + return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]"; + } + return "String a truncated after $i characters" if @b_chars; + return "String b truncated after $i characters" if @a_chars; + return ""; +} + + +sub data_string_desc { # describe a data string + my ($a) = @_; + require bytes; + require utf8; + + # hacks to cater for perl 5.6 + *utf8::is_utf8 = sub { (DBI::neat(shift)=~/^"/) } unless defined &utf8::is_utf8; + *utf8::valid = sub { 1 } unless defined &utf8::valid; + + # Give sufficient info to help diagnose at least these kinds of situations: + # - valid UTF8 byte sequence but UTF8 flag not set + # (might be ascii so also need to check for hibit to make it worthwhile) + # - UTF8 flag set but invalid UTF8 byte sequence + # could do better here, but this'll do for now + my $utf8 = sprintf "UTF8 %s%s", + utf8::is_utf8($a) ? "on" : "off", + utf8::valid($a||'') ? "" : " but INVALID encoding"; + return "$utf8, undef" unless defined $a; + my $is_ascii = $a =~ m/^[\000-\177]*$/; + return sprintf "%s, %s, %d characters %d bytes", + $utf8, $is_ascii ? "ASCII" : "non-ASCII", + length($a), bytes::length($a); +} + + +sub connect_test_perf { + my($class, $dsn,$dbuser,$dbpass, $attr) = @_; + Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr; + # these are non standard attributes just for this special method + my $loops ||= $attr->{dbi_loops} || 5; + my $par ||= $attr->{dbi_par} || 1; # parallelism + my $verb ||= $attr->{dbi_verb} || 1; + my $meth ||= $attr->{dbi_meth} || 'connect'; + print "$dsn: testing $loops sets of $par connections:\n"; + require "FileHandle.pm"; # don't let toke.c create empty FileHandle package + local $| = 1; + my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n"); + # test the connection and warm up caches etc + $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr"); + my $t1 = dbi_time(); + my $loop; + for $loop (1..$loops) { + my @cons; + print "Connecting... " if $verb; + for (1..$par) { + print "$_ "; + push @cons, ($drh->connect($dsn,$dbuser,$dbpass) + or Carp::croak("connect failed: $DBI::errstr\n")); + } + print "\nDisconnecting...\n" if $verb; + for (@cons) { + $_->disconnect or warn "disconnect failed: $DBI::errstr" + } + } + my $t2 = dbi_time(); + my $td = $t2 - $t1; + printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n", + $par, $loops, $td, $loops*$par, $td/($loops*$par); + return $td; +} + + +# Help people doing DBI->errstr, might even document it one day +# XXX probably best moved to cheaper XS code if this gets documented +sub err { $DBI::err } +sub errstr { $DBI::errstr } + + +# --- Private Internal Function for Creating New DBI Handles + +# XXX move to PurePerl? +*DBI::dr::TIEHASH = \&DBI::st::TIEHASH; +*DBI::db::TIEHASH = \&DBI::st::TIEHASH; + + +# These three special constructors are called by the drivers +# The way they are called is likely to change. + +our $shared_profile; + +sub _new_drh { # called by DBD::::driver() + my ($class, $initial_attr, $imp_data) = @_; + # Provide default storage for State,Err and Errstr. + # Note that these are shared by all child handles by default! XXX + # State must be undef to get automatic faking in DBI::var::FETCH + my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, undef, ''); + my $attr = { + # these attributes get copied down to child handles by default + 'State' => \$h_state_store, # Holder for DBI::state + 'Err' => \$h_err_store, # Holder for DBI::err + 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr + 'TraceLevel' => 0, + FetchHashKeyName=> 'NAME', + %$initial_attr, + }; + my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class); + + # XXX DBI_PROFILE unless DBI::PurePerl because for some reason + # it kills the t/zz_*_pp.t tests (they silently exit early) + if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) { + # The profile object created here when the first driver is loaded + # is shared by all drivers so we end up with just one set of profile + # data and thus the 'total time in DBI' is really the true total. + if (!$shared_profile) { # first time + $h->{Profile} = $ENV{DBI_PROFILE}; # write string + $shared_profile = $h->{Profile}; # read and record object + } + else { + $h->{Profile} = $shared_profile; + } + } + return $h unless wantarray; + ($h, $i); +} + +sub _new_dbh { # called by DBD::::dr::connect() + my ($drh, $attr, $imp_data) = @_; + my $imp_class = $drh->{ImplementorClass} + or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); + substr($imp_class,-4,4) = '::db'; + my $app_class = ref $drh; + substr($app_class,-4,4) = '::db'; + $attr->{Err} ||= \my $err; + $attr->{Errstr} ||= \my $errstr; + $attr->{State} ||= \my $state; + _new_handle($app_class, $drh, $attr, $imp_data, $imp_class); +} + +sub _new_sth { # called by DBD::::db::prepare) + my ($dbh, $attr, $imp_data) = @_; + my $imp_class = $dbh->{ImplementorClass} + or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); + substr($imp_class,-4,4) = '::st'; + my $app_class = ref $dbh; + substr($app_class,-4,4) = '::st'; + _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class); +} + + +# end of DBI package + + + +# -------------------------------------------------------------------- +# === The internal DBI Switch pseudo 'driver' class === + +{ package # hide from PAUSE + DBD::Switch::dr; + DBI->setup_driver('DBD::Switch'); # sets up @ISA + + $DBD::Switch::dr::imp_data_size = 0; + $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning + my $drh; + + sub driver { + return $drh if $drh; # a package global + + my $inner; + ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', { + 'Name' => 'Switch', + 'Version' => $DBI::VERSION, + 'Attribution' => "DBI $DBI::VERSION by Tim Bunce", + }); + Carp::croak("DBD::Switch init failed!") unless ($drh && $inner); + return $drh; + } + sub CLONE { + undef $drh; + } + + sub FETCH { + my($drh, $key) = @_; + return DBI->trace if $key eq 'DebugDispatch'; + return undef if $key eq 'DebugLog'; # not worth fetching, sorry + return $drh->DBD::_::dr::FETCH($key); + undef; + } + sub STORE { + my($drh, $key, $value) = @_; + if ($key eq 'DebugDispatch') { + DBI->trace($value); + } elsif ($key eq 'DebugLog') { + DBI->trace(-1, $value); + } else { + $drh->DBD::_::dr::STORE($key, $value); + } + } +} + + +# -------------------------------------------------------------------- +# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES === + +# We only define default methods for harmless functions. +# We don't, for example, define a DBD::_::st::prepare() + +{ package # hide from PAUSE + DBD::_::common; # ====== Common base class methods ====== + use strict; + + # methods common to all handle types: + + # generic TIEHASH default methods: + sub FIRSTKEY { } + sub NEXTKEY { } + sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef? + sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" } + + sub FETCH_many { # XXX should move to C one day + my $h = shift; + # scalar is needed to workaround drivers that return an empty list + # for some attributes + return map { scalar $h->FETCH($_) } @_; + } + + *dump_handle = \&DBI::dump_handle; + + sub install_method { + # special class method called directly by apps and/or drivers + # to install new methods into the DBI dispatcher + # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' }); + my ($class, $method, $attr) = @_; + Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st") + unless $class =~ /^DBD::(\w+)::(dr|db|st)$/; + my ($driver, $subtype) = ($1, $2); + Carp::croak("invalid method name '$method'") + unless $method =~ m/^([a-z][a-z0-9]*_)\w+$/; + my $prefix = $1; + my $reg_info = $dbd_prefix_registry->{$prefix}; + Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info; + + my $full_method = "DBI::${subtype}::$method"; + $DBI::installed_methods{$full_method} = $attr; + + my (undef, $filename, $line) = caller; + # XXX reformat $attr as needed for _install_method + my %attr = %{$attr||{}}; # copy so we can edit + DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr); + } + + sub parse_trace_flags { + my ($h, $spec) = @_; + my $level = 0; + my $flags = 0; + my @unknown; + for my $word (split /\s*[|&,]\s*/, $spec) { + if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) { + $level = $word; + } elsif ($word eq 'ALL') { + $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches + last; + } elsif (my $flag = $h->parse_trace_flag($word)) { + $flags |= $flag; + } + else { + push @unknown, $word; + } + } + if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) { + Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ". + join(" ", map { DBI::neat($_) } @unknown)); + } + $flags |= $level; + return $flags; + } + + sub parse_trace_flag { + my ($h, $name) = @_; + # 0xddDDDDrL (driver, DBI, reserved, Level) + return 0x00000100 if $name eq 'SQL'; + return 0x00000200 if $name eq 'CON'; + return 0x00000400 if $name eq 'ENC'; + return 0x00000800 if $name eq 'DBD'; + return 0x00001000 if $name eq 'TXN'; + return; + } + + sub private_attribute_info { + return undef; + } + + sub visit_child_handles { + my ($h, $code, $info) = @_; + $info = {} if not defined $info; + for my $ch (@{ $h->{ChildHandles} || []}) { + next unless $ch; + my $child_info = $code->($ch, $info) + or next; + $ch->visit_child_handles($code, $child_info); + } + return $info; + } +} + + +{ package # hide from PAUSE + DBD::_::dr; # ====== DRIVER ====== + @DBD::_::dr::ISA = qw(DBD::_::common); + use strict; + + sub default_user { + my ($drh, $user, $pass, $attr) = @_; + $user = $ENV{DBI_USER} unless defined $user; + $pass = $ENV{DBI_PASS} unless defined $pass; + return ($user, $pass); + } + + sub connect { # normally overridden, but a handy default + my ($drh, $dsn, $user, $auth) = @_; + my ($this) = DBI::_new_dbh($drh, { + 'Name' => $dsn, + }); + # XXX debatable as there's no "server side" here + # (and now many uses would trigger warnings on DESTROY) + # $this->STORE(Active => 1); + # so drivers should set it in their own connect + $this; + } + + + sub connect_cached { + my $drh = shift; + my ($dsn, $user, $auth, $attr) = @_; + + my $cache = $drh->{CachedKids} ||= {}; + my $key = do { local $^W; + join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) + }; + my $dbh = $cache->{$key}; + $drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh))) + if (($DBI::dbi_debug & 0xF) >= 4); + + my $cb = $attr->{Callbacks}; # take care not to autovivify + if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) { + # If the caller has provided a callback then call it + if ($cb and $cb = $cb->{"connect_cached.reused"}) { + local $_ = "connect_cached.reused"; + $cb->($dbh, $dsn, $user, $auth, $attr); + } + return $dbh; + } + + # If the caller has provided a callback then call it + if ($cb and (my $new_cb = $cb->{"connect_cached.new"})) { + local $_ = "connect_cached.new"; + $new_cb->($dbh, $dsn, $user, $auth, $attr); # $dbh is dead or undef + } + + $dbh = $drh->connect(@_); + $cache->{$key} = $dbh; # replace prev entry, even if connect failed + if ($cb and (my $conn_cb = $cb->{"connect_cached.connected"})) { + local $_ = "connect_cached.connected"; + $conn_cb->($dbh, $dsn, $user, $auth, $attr); + } + return $dbh; + } + +} + + +{ package # hide from PAUSE + DBD::_::db; # ====== DATABASE ====== + @DBD::_::db::ISA = qw(DBD::_::common); + use strict; + + sub clone { + my ($old_dbh, $attr) = @_; + + my $closure = $old_dbh->{dbi_connect_closure} + or return $old_dbh->set_err($DBI::stderr, "Can't clone handle"); + + unless ($attr) { # XXX deprecated, caller should always pass a hash ref + # copy attributes visible in the attribute cache + keys %$old_dbh; # reset iterator + while ( my ($k, $v) = each %$old_dbh ) { + # ignore non-code refs, i.e., caches, handles, Err etc + next if ref $v && ref $v ne 'CODE'; # HandleError etc + $attr->{$k} = $v; + } + # explicitly set attributes which are unlikely to be in the + # attribute cache, i.e., boolean's and some others + $attr->{$_} = $old_dbh->FETCH($_) for (qw( + AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy + LongTruncOk PrintError PrintWarn Profile RaiseError + ShowErrorStatement TaintIn TaintOut + )); + } + + # use Data::Dumper; warn Dumper([$old_dbh, $attr]); + my $new_dbh = &$closure($old_dbh, $attr); + unless ($new_dbh) { + # need to copy err/errstr from driver back into $old_dbh + my $drh = $old_dbh->{Driver}; + return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state); + } + $new_dbh->{dbi_connect_closure} = $closure; + return $new_dbh; + } + + sub quote_identifier { + my ($dbh, @id) = @_; + my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef; + + my $info = $dbh->{dbi_quote_identifier_cache} ||= [ + $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR + $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR + $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION + ]; + + my $quote = $info->[0]; + foreach (@id) { # quote the elements + next unless defined; + s/$quote/$quote$quote/g; # escape embedded quotes + $_ = qq{$quote$_$quote}; + } + + # strip out catalog if present for special handling + my $catalog = (@id >= 3) ? shift @id : undef; + + # join the dots, ignoring any null/undef elements (ie schema) + my $quoted_id = join '.', grep { defined } @id; + + if ($catalog) { # add catalog correctly + if ($quoted_id) { + $quoted_id = ($info->[2] == 2) # SQL_CL_END + ? $quoted_id . $info->[1] . $catalog + : $catalog . $info->[1] . $quoted_id; + } else { + $quoted_id = $catalog; + } + } + return $quoted_id; + } + + sub quote { + my ($dbh, $str, $data_type) = @_; + + return "NULL" unless defined $str; + unless ($data_type) { + $str =~ s/'/''/g; # ISO SQL2 + return "'$str'"; + } + + my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ]; + my ($prefixes, $suffixes) = @$dbi_literal_quote_cache; + + my $lp = $prefixes->{$data_type}; + my $ls = $suffixes->{$data_type}; + + if ( ! defined $lp || ! defined $ls ) { + my $ti = $dbh->type_info($data_type); + $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'"; + $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'"; + } + return $str unless $lp || $ls; # no quoting required + + # XXX don't know what the standard says about escaping + # in the 'general case' (where $lp != "'"). + # So we just do this and hope: + $str =~ s/$lp/$lp$lp/g + if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"'); + return "$lp$str$ls"; + } + + sub rows { -1 } # here so $DBI::rows 'works' after using $dbh + + sub do { + my($dbh, $statement, $attr, @params) = @_; + my $sth = $dbh->prepare($statement, $attr) or return undef; + $sth->execute(@params) or return undef; + my $rows = $sth->rows; + ($rows == 0) ? "0E0" : $rows; + } + + sub _do_selectrow { + my ($method, $dbh, $stmt, $attr, @bind) = @_; + my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)) + or return undef; + $sth->execute(@bind) + or return undef; + my $row = $sth->$method() + and $sth->finish; + return $row; + } + + sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); } + + # XXX selectrow_array/ref also have C implementations in Driver.xst + sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); } + sub selectrow_array { + my $row = _do_selectrow('fetchrow_arrayref', @_) or return; + return $row->[0] unless wantarray; + return @$row; + } + + sub selectall_array { + return @{ shift->selectall_arrayref(@_) || [] }; + } + + # XXX selectall_arrayref also has C implementation in Driver.xst + # which fallsback to this if a slice is given + sub selectall_arrayref { + my ($dbh, $stmt, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr) + or return; + $sth->execute(@bind) || return; + my $slice = $attr->{Slice}; # typically undef, else hash or array ref + if (!$slice and $slice=$attr->{Columns}) { + if (ref $slice eq 'ARRAY') { # map col idx to perl array idx + $slice = [ @{$attr->{Columns}} ]; # take a copy + for (@$slice) { $_-- } + } + } + my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows}); + $sth->finish if defined $MaxRows; + return $rows; + } + + sub selectall_hashref { + my ($dbh, $stmt, $key_field, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr); + return unless $sth; + $sth->execute(@bind) || return; + return $sth->fetchall_hashref($key_field); + } + + sub selectcol_arrayref { + my ($dbh, $stmt, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr); + return unless $sth; + $sth->execute(@bind) || return; + my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1); + my @values = (undef) x @columns; + my $idx = 0; + for (@columns) { + $sth->bind_col($_, \$values[$idx++]) || return; + } + my @col; + if (my $max = $attr->{MaxRows}) { + push @col, @values while 0 < $max-- && $sth->fetch; + } + else { + push @col, @values while $sth->fetch; + } + return \@col; + } + + sub prepare_cached { + my ($dbh, $statement, $attr, $if_active) = @_; + + # Needs support at dbh level to clear cache before complaining about + # active children. The XS template code does this. Drivers not using + # the template must handle clearing the cache themselves. + my $cache = $dbh->{CachedKids} ||= {}; + my $key = do { local $^W; + join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) + }; + my $sth = $cache->{$key}; + + if ($sth) { + return $sth unless $sth->FETCH('Active'); + Carp::carp("prepare_cached($statement) statement handle $sth still Active") + unless ($if_active ||= 0); + $sth->finish if $if_active <= 1; + return $sth if $if_active <= 2; + } + + $sth = $dbh->prepare($statement, $attr); + $cache->{$key} = $sth if $sth; + + return $sth; + } + + sub ping { + my $dbh = shift; + # "0 but true" is a special kind of true 0 that is used here so + # applications can check if the ping was a real ping or not + ($dbh->FETCH('Active')) ? "0 but true" : 0; + } + + sub begin_work { + my $dbh = shift; + return $dbh->set_err($DBI::stderr, "Already in a transaction") + unless $dbh->FETCH('AutoCommit'); + $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it + $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action + return 1; + } + + sub primary_key { + my ($dbh, @args) = @_; + my $sth = $dbh->primary_key_info(@args) or return; + my ($row, @col); + push @col, $row->[3] while ($row = $sth->fetch); + Carp::croak("primary_key method not called in list context") + unless wantarray; # leave us some elbow room + return @col; + } + + sub tables { + my ($dbh, @args) = @_; + my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return; + my $tables = $sth->fetchall_arrayref or return; + my @tables; + if (defined($args[3]) && $args[3] eq '%' # special case for tables('','','','%') + && grep {defined($_) && $_ eq ''} @args[0,1,2] + ) { + @tables = map { $_->[3] } @$tables; + } elsif ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR + @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables; + } + else { # temporary old style hack (yeach) + @tables = map { + my $name = $_->[2]; + if ($_->[1]) { + my $schema = $_->[1]; + # a sad hack (mostly for Informix I recall) + my $quote = ($schema eq uc($schema)) ? '' : '"'; + $name = "$quote$schema$quote.$name" + } + $name; + } @$tables; + } + return @tables; + } + + sub type_info { # this should be sufficient for all drivers + my ($dbh, $data_type) = @_; + my $idx_hash; + my $tia = $dbh->{dbi_type_info_row_cache}; + if ($tia) { + $idx_hash = $dbh->{dbi_type_info_idx_cache}; + } + else { + my $temp = $dbh->type_info_all; + return unless $temp && @$temp; + # we cache here because type_info_all may be expensive to call + # (and we take a copy so the following shift can't corrupt + # the data that may be returned by future calls to type_info_all) + $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ]; + $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia; + } + + my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type}; + Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)") + if $dt_idx && $dt_idx != 1; + + # --- simple DATA_TYPE match filter + my @ti; + my @data_type_list = (ref $data_type) ? @$data_type : ($data_type); + foreach $data_type (@data_type_list) { + if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) { + push @ti, grep { $_->[$dt_idx] == $data_type } @$tia; + } + else { # SQL_ALL_TYPES + push @ti, @$tia; + } + last if @ti; # found at least one match + } + + # --- format results into list of hash refs + my $idx_fields = keys %$idx_hash; + my @idx_names = map { uc($_) } keys %$idx_hash; + my @idx_values = values %$idx_hash; + Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields" + if @ti && @{$ti[0]} != $idx_fields; + my @out = map { + my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h; + } @ti; + return $out[0] unless wantarray; + return @out; + } + + sub data_sources { + my ($dbh, @other) = @_; + my $drh = $dbh->{Driver}; # XXX proxy issues? + return $drh->data_sources(@other); + } + +} + + +{ package # hide from PAUSE + DBD::_::st; # ====== STATEMENT ====== + @DBD::_::st::ISA = qw(DBD::_::common); + use strict; + + sub bind_param { Carp::croak("Can't bind_param, not implement by driver") } + +# +# ******************************************************** +# +# BEGIN ARRAY BINDING +# +# Array binding support for drivers which don't support +# array binding, but have sufficient interfaces to fake it. +# NOTE: mixing scalars and arrayrefs requires using bind_param_array +# for *all* params...unless we modify bind_param for the default +# case... +# +# 2002-Apr-10 D. Arnold + + sub bind_param_array { + my $sth = shift; + my ($p_id, $value_array, $attr) = @_; + + return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) + if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY'; + + return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array") + unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here + + return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range") + if $p_id <= 0; # can't easily/reliably test for too big + + # get/create arrayref to hold params + my $hash_of_arrays = $sth->{ParamArrays} ||= { }; + + # If the bind has attribs then we rely on the driver conforming to + # the DBI spec in that a single bind_param() call with those attribs + # makes them 'sticky' and apply to all later execute(@values) calls. + # Since we only call bind_param() if we're given attribs then + # applications using drivers that don't support bind_param can still + # use bind_param_array() so long as they don't pass any attribs. + + $$hash_of_arrays{$p_id} = $value_array; + return $sth->bind_param($p_id, undef, $attr) + if $attr; + 1; + } + + sub bind_param_inout_array { + my $sth = shift; + # XXX not supported so we just call bind_param_array instead + # and then return an error + my ($p_num, $value_array, $attr) = @_; + $sth->bind_param_array($p_num, $value_array, $attr); + return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported"); + } + + sub bind_columns { + my $sth = shift; + my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0; + if ($fields <= 0 && !$sth->{Active}) { + return $sth->set_err($DBI::stderr, "Statement has no result columns to bind" + ." (perhaps you need to successfully call execute first, or again)"); + } + # Backwards compatibility for old-style call with attribute hash + # ref as first arg. Skip arg if undef or a hash ref. + my $attr; + $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH'; + + my $idx = 0; + $sth->bind_col(++$idx, shift, $attr) or return + while (@_ and $idx < $fields); + + return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed") + if @_ or $idx != $fields; + + return 1; + } + + sub execute_array { + my $sth = shift; + my ($attr, @array_of_arrays) = @_; + my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point + + # get tuple status array or hash attribute + my $tuple_sts = $attr->{ArrayTupleStatus}; + return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref") + if $tuple_sts and ref $tuple_sts ne 'ARRAY'; + + # bind all supplied arrays + if (@array_of_arrays) { + $sth->{ParamArrays} = { }; # clear out old params + return $sth->set_err($DBI::stderr, + @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected") + if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS; + $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return + foreach (1..@array_of_arrays); + } + + my $fetch_tuple_sub; + + if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand + + return $sth->set_err($DBI::stderr, + "Can't use both ArrayTupleFetch and explicit bind values") + if @array_of_arrays; # previous bind_param_array calls will simply be ignored + + if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) { + my $fetch_sth = $fetch_tuple_sub; + return $sth->set_err($DBI::stderr, + "ArrayTupleFetch sth is not Active, need to execute() it first") + unless $fetch_sth->{Active}; + # check column count match to give more friendly message + my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS}; + return $sth->set_err($DBI::stderr, + "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected") + if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS) + && $NUM_OF_FIELDS != $NUM_OF_PARAMS; + $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref }; + } + elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) { + return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle"); + } + + } + else { + my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} }; + return $sth->set_err($DBI::stderr, + "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected") + if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given; + + # get the length of a bound array + my $maxlen; + my %hash_of_arrays = %{$sth->{ParamArrays}}; + foreach (keys(%hash_of_arrays)) { + my $ary = $hash_of_arrays{$_}; + next unless ref $ary eq 'ARRAY'; + $maxlen = @$ary if !$maxlen || @$ary > $maxlen; + } + # if there are no arrays then execute scalars once + $maxlen = 1 unless defined $maxlen; + my @bind_ids = 1..keys(%hash_of_arrays); + + my $tuple_idx = 0; + $fetch_tuple_sub = sub { + return if $tuple_idx >= $maxlen; + my @tuple = map { + my $a = $hash_of_arrays{$_}; + ref($a) ? $a->[$tuple_idx] : $a + } @bind_ids; + ++$tuple_idx; + return \@tuple; + }; + } + # pass thru the callers scalar or list context + return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts); + } + + sub execute_for_fetch { + my ($sth, $fetch_tuple_sub, $tuple_status) = @_; + # start with empty status array + ($tuple_status) ? @$tuple_status = () : $tuple_status = []; + + my $rc_total = 0; + my $err_count; + while ( my $tuple = &$fetch_tuple_sub() ) { + if ( my $rc = $sth->execute(@$tuple) ) { + push @$tuple_status, $rc; + $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1; + } + else { + $err_count++; + push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ]; + # XXX drivers implementing execute_for_fetch could opt to "last;" here + # if they know the error code means no further executes will work. + } + } + my $tuples = @$tuple_status; + return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors") + if $err_count; + $tuples ||= "0E0"; + return $tuples unless wantarray; + return ($tuples, $rc_total); + } + + + sub fetchall_arrayref { # ALSO IN Driver.xst + my ($sth, $slice, $max_rows) = @_; + + # when batch fetching with $max_rows were very likely to try to + # fetch the 'next batch' after the previous batch returned + # <=$max_rows. So don't treat that as an error. + return undef if $max_rows and not $sth->FETCH('Active'); + + my $mode = ref($slice) || 'ARRAY'; + my @rows; + + if ($mode eq 'ARRAY') { + my $row; + # we copy the array here because fetch (currently) always + # returns the same array ref. XXX + if ($slice && @$slice) { + $max_rows = -1 unless defined $max_rows; + push @rows, [ @{$row}[ @$slice] ] + while($max_rows-- and $row = $sth->fetch); + } + elsif (defined $max_rows) { + push @rows, [ @$row ] + while($max_rows-- and $row = $sth->fetch); + } + else { + push @rows, [ @$row ] while($row = $sth->fetch); + } + return \@rows + } + + my %row; + if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name } + keys %$$slice; # reset the iterator + while ( my ($idx, $name) = each %$$slice ) { + $sth->bind_col($idx+1, \$row{$name}); + } + } + elsif ($mode eq 'HASH') { + if (keys %$slice) { # resets the iterator + my $name2idx = $sth->FETCH('NAME_lc_hash'); + while ( my ($name, $unused) = each %$slice ) { + my $idx = $name2idx->{lc $name}; + return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice") + if not defined $idx; + $sth->bind_col($idx+1, \$row{$name}); + } + } + else { + my @column_names = @{ $sth->FETCH($sth->FETCH('FetchHashKeyName')) }; + return [] if !@column_names; + + $sth->bind_columns( \( @row{@column_names} ) ); + } + } + else { + return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid"); + } + + if (not defined $max_rows) { + push @rows, { %row } while ($sth->fetch); # full speed ahead! + } + else { + push @rows, { %row } while ($max_rows-- and $sth->fetch); + } + + return \@rows; + } + + sub fetchall_hashref { + my ($sth, $key_field) = @_; + + my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME'; + my $names_hash = $sth->FETCH("${hash_key_name}_hash"); + my @key_fields = (ref $key_field) ? @$key_field : ($key_field); + my @key_indexes; + my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS'); + foreach (@key_fields) { + my $index = $names_hash->{$_}; # perl index not column + $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields; + return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})") + unless defined $index; + push @key_indexes, $index; + } + my $rows = {}; + my $NAME = $sth->FETCH($hash_key_name); + my @row = (undef) x $num_of_fields; + $sth->bind_columns(\(@row)); + while ($sth->fetch) { + my $ref = $rows; + $ref = $ref->{$row[$_]} ||= {} for @key_indexes; + @{$ref}{@$NAME} = @row; + } + return $rows; + } + + *dump_results = \&DBI::dump_results; + + sub blob_copy_to_file { # returns length or undef on error + my($self, $field, $filename_or_handleref, $blocksize) = @_; + my $fh = $filename_or_handleref; + my($len, $buf) = (0, ""); + $blocksize ||= 512; # not too ambitious + local(*FH); + unless(ref $fh) { + open(FH, ">$fh") || return undef; + $fh = \*FH; + } + while(defined($self->blob_read($field, $len, $blocksize, \$buf))) { + print $fh $buf; + $len += length $buf; + } + close(FH); + $len; + } + + sub more_results { + shift->{syb_more_results}; # handy grandfathering + } + +} + +unless ($DBI::PurePerl) { # See install_driver + { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); } + { @DBD::_mem::db::ISA = qw(DBD::_mem::common); } + { @DBD::_mem::st::ISA = qw(DBD::_mem::common); } + # DBD::_mem::common::DESTROY is implemented in DBI.xs +} + +1; +__END__ + +#line 8426 + +# LocalWords: DBI diff --git a/apps/lib/DBI/Const/GetInfo/ANSI.pm b/apps/lib/DBI/Const/GetInfo/ANSI.pm new file mode 100644 index 0000000..5f22e0f --- /dev/null +++ b/apps/lib/DBI/Const/GetInfo/ANSI.pm @@ -0,0 +1,198 @@ +#line 1 "DBI/Const/GetInfo/ANSI.pm" +# $Id: ANSI.pm 8696 2007-01-24 23:12:38Z Tim $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing ANSI CLI info types and return values for the +# SQLGetInfo() method of ODBC. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. +use strict; + +package DBI::Const::GetInfo::ANSI; + +our (%InfoTypes,%ReturnTypes,%ReturnValues,); + +#line 42 + +my +$VERSION = "2.008697"; + +%InfoTypes = +( + SQL_ALTER_TABLE => 86 +, SQL_CATALOG_NAME => 10003 +, SQL_COLLATING_SEQUENCE => 10004 +, SQL_CURSOR_COMMIT_BEHAVIOR => 23 +, SQL_CURSOR_SENSITIVITY => 10001 +, SQL_DATA_SOURCE_NAME => 2 +, SQL_DATA_SOURCE_READ_ONLY => 25 +, SQL_DBMS_NAME => 17 +, SQL_DBMS_VERSION => 18 +, SQL_DEFAULT_TRANSACTION_ISOLATION => 26 +, SQL_DESCRIBE_PARAMETER => 10002 +, SQL_FETCH_DIRECTION => 8 +, SQL_GETDATA_EXTENSIONS => 81 +, SQL_IDENTIFIER_CASE => 28 +, SQL_INTEGRITY => 73 +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 +, SQL_MAXIMUM_COLUMNS_IN_TABLE => 101 +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 +, SQL_MAXIMUM_STMT_OCTETS => 20000 +, SQL_MAXIMUM_STMT_OCTETS_DATA => 20001 +, SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 20002 +, SQL_MAXIMUM_TABLES_IN_SELECT => 106 +, SQL_MAXIMUM_TABLE_NAME_LENGTH => 35 +, SQL_MAXIMUM_USER_NAME_LENGTH => 107 +, SQL_NULL_COLLATION => 85 +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 90 +, SQL_OUTER_JOIN_CAPABILITIES => 115 +, SQL_SCROLL_CONCURRENCY => 43 +, SQL_SEARCH_PATTERN_ESCAPE => 14 +, SQL_SERVER_NAME => 13 +, SQL_SPECIAL_CHARACTERS => 94 +, SQL_TRANSACTION_CAPABLE => 46 +, SQL_TRANSACTION_ISOLATION_OPTION => 72 +, SQL_USER_NAME => 47 +); + +#line 99 + +%ReturnTypes = # maxlen +( + SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # INTEGER +, SQL_CATALOG_NAME => 'SQLCHAR' # CHARACTER (1) +, SQL_COLLATING_SEQUENCE => 'SQLCHAR' # CHARACTER (254) +, SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # SMALLINT +, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # INTEGER +, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # CHARACTER (128) +, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # CHARACTER (1) +, SQL_DBMS_NAME => 'SQLCHAR' # CHARACTER (254) +, SQL_DBMS_VERSION => 'SQLCHAR' # CHARACTER (254) +, SQL_DEFAULT_TRANSACTION_ISOLATION => 'SQLUINTEGER' # INTEGER +, SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # CHARACTER (1) +, SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # INTEGER +, SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # INTEGER +, SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # SMALLINT +, SQL_INTEGRITY => 'SQLCHAR' # CHARACTER (1) +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_STMT_OCTETS => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_STMT_OCTETS_DATA => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_STMT_OCTETS_SCHEMA => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_TABLE_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # SMALLINT +, SQL_NULL_COLLATION => 'SQLUSMALLINT' # SMALLINT +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # CHARACTER (1) +, SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # INTEGER +, SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # INTEGER +, SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # CHARACTER (1) +, SQL_SERVER_NAME => 'SQLCHAR' # CHARACTER (128) +, SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # CHARACTER (254) +, SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # SMALLINT +, SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # INTEGER +, SQL_USER_NAME => 'SQLCHAR' # CHARACTER (128) +); + +#line 151 + +$ReturnValues{SQL_ALTER_TABLE} = +{ + SQL_AT_ADD_COLUMN => 0x00000001 +, SQL_AT_DROP_COLUMN => 0x00000002 +, SQL_AT_ALTER_COLUMN => 0x00000004 +, SQL_AT_ADD_CONSTRAINT => 0x00000008 +, SQL_AT_DROP_CONSTRAINT => 0x00000010 +}; +$ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} = +{ + SQL_CB_DELETE => 0 +, SQL_CB_CLOSE => 1 +, SQL_CB_PRESERVE => 2 +}; +$ReturnValues{SQL_FETCH_DIRECTION} = +{ + SQL_FD_FETCH_NEXT => 0x00000001 +, SQL_FD_FETCH_FIRST => 0x00000002 +, SQL_FD_FETCH_LAST => 0x00000004 +, SQL_FD_FETCH_PRIOR => 0x00000008 +, SQL_FD_FETCH_ABSOLUTE => 0x00000010 +, SQL_FD_FETCH_RELATIVE => 0x00000020 +}; +$ReturnValues{SQL_GETDATA_EXTENSIONS} = +{ + SQL_GD_ANY_COLUMN => 0x00000001 +, SQL_GD_ANY_ORDER => 0x00000002 +}; +$ReturnValues{SQL_IDENTIFIER_CASE} = +{ + SQL_IC_UPPER => 1 +, SQL_IC_LOWER => 2 +, SQL_IC_SENSITIVE => 3 +, SQL_IC_MIXED => 4 +}; +$ReturnValues{SQL_NULL_COLLATION} = +{ + SQL_NC_HIGH => 1 +, SQL_NC_LOW => 2 +}; +$ReturnValues{SQL_OUTER_JOIN_CAPABILITIES} = +{ + SQL_OUTER_JOIN_LEFT => 0x00000001 +, SQL_OUTER_JOIN_RIGHT => 0x00000002 +, SQL_OUTER_JOIN_FULL => 0x00000004 +, SQL_OUTER_JOIN_NESTED => 0x00000008 +, SQL_OUTER_JOIN_NOT_ORDERED => 0x00000010 +, SQL_OUTER_JOIN_INNER => 0x00000020 +, SQL_OUTER_JOIN_ALL_COMPARISON_OPS => 0x00000040 +}; +$ReturnValues{SQL_SCROLL_CONCURRENCY} = +{ + SQL_SCCO_READ_ONLY => 0x00000001 +, SQL_SCCO_LOCK => 0x00000002 +, SQL_SCCO_OPT_ROWVER => 0x00000004 +, SQL_SCCO_OPT_VALUES => 0x00000008 +}; +$ReturnValues{SQL_TRANSACTION_ACCESS_MODE} = +{ + SQL_TRANSACTION_READ_ONLY => 0x00000001 +, SQL_TRANSACTION_READ_WRITE => 0x00000002 +}; +$ReturnValues{SQL_TRANSACTION_CAPABLE} = +{ + SQL_TC_NONE => 0 +, SQL_TC_DML => 1 +, SQL_TC_ALL => 2 +, SQL_TC_DDL_COMMIT => 3 +, SQL_TC_DDL_IGNORE => 4 +}; +$ReturnValues{SQL_TRANSACTION_ISOLATION} = +{ + SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 +, SQL_TRANSACTION_READ_COMMITTED => 0x00000002 +, SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 +, SQL_TRANSACTION_SERIALIZABLE => 0x00000008 +}; + +1; + +#line 239 diff --git a/apps/lib/DBI/Const/GetInfo/ODBC.pm b/apps/lib/DBI/Const/GetInfo/ODBC.pm new file mode 100644 index 0000000..2c31c00 --- /dev/null +++ b/apps/lib/DBI/Const/GetInfo/ODBC.pm @@ -0,0 +1,1323 @@ +#line 1 "DBI/Const/GetInfo/ODBC.pm" +# $Id: ODBC.pm 11373 2008-06-02 19:01:33Z Tim $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing Microsoft ODBC info types and return values +# for the SQLGetInfo() method of ODBC. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. +use strict; +package DBI::Const::GetInfo::ODBC; + +our (%InfoTypes,%ReturnTypes,%ReturnValues,); +#line 37 + +my +$VERSION = "2.011374"; + +%InfoTypes = +( + SQL_ACCESSIBLE_PROCEDURES => 20 +, SQL_ACCESSIBLE_TABLES => 19 +, SQL_ACTIVE_CONNECTIONS => 0 +, SQL_ACTIVE_ENVIRONMENTS => 116 +, SQL_ACTIVE_STATEMENTS => 1 +, SQL_AGGREGATE_FUNCTIONS => 169 +, SQL_ALTER_DOMAIN => 117 +, SQL_ALTER_TABLE => 86 +, SQL_ASYNC_MODE => 10021 +, SQL_BATCH_ROW_COUNT => 120 +, SQL_BATCH_SUPPORT => 121 +, SQL_BOOKMARK_PERSISTENCE => 82 +, SQL_CATALOG_LOCATION => 114 # SQL_QUALIFIER_LOCATION +, SQL_CATALOG_NAME => 10003 +, SQL_CATALOG_NAME_SEPARATOR => 41 # SQL_QUALIFIER_NAME_SEPARATOR +, SQL_CATALOG_TERM => 42 # SQL_QUALIFIER_TERM +, SQL_CATALOG_USAGE => 92 # SQL_QUALIFIER_USAGE +, SQL_COLLATION_SEQ => 10004 +, SQL_COLUMN_ALIAS => 87 +, SQL_CONCAT_NULL_BEHAVIOR => 22 +, SQL_CONVERT_BIGINT => 53 +, SQL_CONVERT_BINARY => 54 +, SQL_CONVERT_BIT => 55 +, SQL_CONVERT_CHAR => 56 +, SQL_CONVERT_DATE => 57 +, SQL_CONVERT_DECIMAL => 58 +, SQL_CONVERT_DOUBLE => 59 +, SQL_CONVERT_FLOAT => 60 +, SQL_CONVERT_FUNCTIONS => 48 +, SQL_CONVERT_GUID => 173 +, SQL_CONVERT_INTEGER => 61 +, SQL_CONVERT_INTERVAL_DAY_TIME => 123 +, SQL_CONVERT_INTERVAL_YEAR_MONTH => 124 +, SQL_CONVERT_LONGVARBINARY => 71 +, SQL_CONVERT_LONGVARCHAR => 62 +, SQL_CONVERT_NUMERIC => 63 +, SQL_CONVERT_REAL => 64 +, SQL_CONVERT_SMALLINT => 65 +, SQL_CONVERT_TIME => 66 +, SQL_CONVERT_TIMESTAMP => 67 +, SQL_CONVERT_TINYINT => 68 +, SQL_CONVERT_VARBINARY => 69 +, SQL_CONVERT_VARCHAR => 70 +, SQL_CONVERT_WCHAR => 122 +, SQL_CONVERT_WLONGVARCHAR => 125 +, SQL_CONVERT_WVARCHAR => 126 +, SQL_CORRELATION_NAME => 74 +, SQL_CREATE_ASSERTION => 127 +, SQL_CREATE_CHARACTER_SET => 128 +, SQL_CREATE_COLLATION => 129 +, SQL_CREATE_DOMAIN => 130 +, SQL_CREATE_SCHEMA => 131 +, SQL_CREATE_TABLE => 132 +, SQL_CREATE_TRANSLATION => 133 +, SQL_CREATE_VIEW => 134 +, SQL_CURSOR_COMMIT_BEHAVIOR => 23 +, SQL_CURSOR_ROLLBACK_BEHAVIOR => 24 +, SQL_CURSOR_SENSITIVITY => 10001 +, SQL_DATA_SOURCE_NAME => 2 +, SQL_DATA_SOURCE_READ_ONLY => 25 +, SQL_DATABASE_NAME => 16 +, SQL_DATETIME_LITERALS => 119 +, SQL_DBMS_NAME => 17 +, SQL_DBMS_VER => 18 +, SQL_DDL_INDEX => 170 +, SQL_DEFAULT_TXN_ISOLATION => 26 +, SQL_DESCRIBE_PARAMETER => 10002 +, SQL_DM_VER => 171 +, SQL_DRIVER_HDBC => 3 +, SQL_DRIVER_HDESC => 135 +, SQL_DRIVER_HENV => 4 +, SQL_DRIVER_HLIB => 76 +, SQL_DRIVER_HSTMT => 5 +, SQL_DRIVER_NAME => 6 +, SQL_DRIVER_ODBC_VER => 77 +, SQL_DRIVER_VER => 7 +, SQL_DROP_ASSERTION => 136 +, SQL_DROP_CHARACTER_SET => 137 +, SQL_DROP_COLLATION => 138 +, SQL_DROP_DOMAIN => 139 +, SQL_DROP_SCHEMA => 140 +, SQL_DROP_TABLE => 141 +, SQL_DROP_TRANSLATION => 142 +, SQL_DROP_VIEW => 143 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 144 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 145 +, SQL_EXPRESSIONS_IN_ORDERBY => 27 +, SQL_FETCH_DIRECTION => 8 +, SQL_FILE_USAGE => 84 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 146 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 147 +, SQL_GETDATA_EXTENSIONS => 81 +, SQL_GROUP_BY => 88 +, SQL_IDENTIFIER_CASE => 28 +, SQL_IDENTIFIER_QUOTE_CHAR => 29 +, SQL_INDEX_KEYWORDS => 148 +# SQL_INFO_DRIVER_START => 1000 +# SQL_INFO_FIRST => 0 +# SQL_INFO_LAST => 114 # SQL_QUALIFIER_LOCATION +, SQL_INFO_SCHEMA_VIEWS => 149 +, SQL_INSERT_STATEMENT => 172 +, SQL_INTEGRITY => 73 +, SQL_KEYSET_CURSOR_ATTRIBUTES1 => 150 +, SQL_KEYSET_CURSOR_ATTRIBUTES2 => 151 +, SQL_KEYWORDS => 89 +, SQL_LIKE_ESCAPE_CLAUSE => 113 +, SQL_LOCK_TYPES => 78 +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 34 # SQL_MAX_CATALOG_NAME_LEN +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 97 # SQL_MAX_COLUMNS_IN_GROUP_BY +, SQL_MAXIMUM_COLUMNS_IN_INDEX => 98 # SQL_MAX_COLUMNS_IN_INDEX +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 99 # SQL_MAX_COLUMNS_IN_ORDER_BY +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 100 # SQL_MAX_COLUMNS_IN_SELECT +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 30 # SQL_MAX_COLUMN_NAME_LEN +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 1 # SQL_MAX_CONCURRENT_ACTIVITIES +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 31 # SQL_MAX_CURSOR_NAME_LEN +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 0 # SQL_MAX_DRIVER_CONNECTIONS +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 10005 # SQL_MAX_IDENTIFIER_LEN +, SQL_MAXIMUM_INDEX_SIZE => 102 # SQL_MAX_INDEX_SIZE +, SQL_MAXIMUM_ROW_SIZE => 104 # SQL_MAX_ROW_SIZE +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 32 # SQL_MAX_SCHEMA_NAME_LEN +, SQL_MAXIMUM_STATEMENT_LENGTH => 105 # SQL_MAX_STATEMENT_LEN +, SQL_MAXIMUM_TABLES_IN_SELECT => 106 # SQL_MAX_TABLES_IN_SELECT +, SQL_MAXIMUM_USER_NAME_LENGTH => 107 # SQL_MAX_USER_NAME_LEN +, SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 10022 +, SQL_MAX_BINARY_LITERAL_LEN => 112 +, SQL_MAX_CATALOG_NAME_LEN => 34 +, SQL_MAX_CHAR_LITERAL_LEN => 108 +, SQL_MAX_COLUMNS_IN_GROUP_BY => 97 +, SQL_MAX_COLUMNS_IN_INDEX => 98 +, SQL_MAX_COLUMNS_IN_ORDER_BY => 99 +, SQL_MAX_COLUMNS_IN_SELECT => 100 +, SQL_MAX_COLUMNS_IN_TABLE => 101 +, SQL_MAX_COLUMN_NAME_LEN => 30 +, SQL_MAX_CONCURRENT_ACTIVITIES => 1 +, SQL_MAX_CURSOR_NAME_LEN => 31 +, SQL_MAX_DRIVER_CONNECTIONS => 0 +, SQL_MAX_IDENTIFIER_LEN => 10005 +, SQL_MAX_INDEX_SIZE => 102 +, SQL_MAX_OWNER_NAME_LEN => 32 +, SQL_MAX_PROCEDURE_NAME_LEN => 33 +, SQL_MAX_QUALIFIER_NAME_LEN => 34 +, SQL_MAX_ROW_SIZE => 104 +, SQL_MAX_ROW_SIZE_INCLUDES_LONG => 103 +, SQL_MAX_SCHEMA_NAME_LEN => 32 +, SQL_MAX_STATEMENT_LEN => 105 +, SQL_MAX_TABLES_IN_SELECT => 106 +, SQL_MAX_TABLE_NAME_LEN => 35 +, SQL_MAX_USER_NAME_LEN => 107 +, SQL_MULTIPLE_ACTIVE_TXN => 37 +, SQL_MULT_RESULT_SETS => 36 +, SQL_NEED_LONG_DATA_LEN => 111 +, SQL_NON_NULLABLE_COLUMNS => 75 +, SQL_NULL_COLLATION => 85 +, SQL_NUMERIC_FUNCTIONS => 49 +, SQL_ODBC_API_CONFORMANCE => 9 +, SQL_ODBC_INTERFACE_CONFORMANCE => 152 +, SQL_ODBC_SAG_CLI_CONFORMANCE => 12 +, SQL_ODBC_SQL_CONFORMANCE => 15 +, SQL_ODBC_SQL_OPT_IEF => 73 +, SQL_ODBC_VER => 10 +, SQL_OJ_CAPABILITIES => 115 +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 90 +, SQL_OUTER_JOINS => 38 +, SQL_OUTER_JOIN_CAPABILITIES => 115 # SQL_OJ_CAPABILITIES +, SQL_OWNER_TERM => 39 +, SQL_OWNER_USAGE => 91 +, SQL_PARAM_ARRAY_ROW_COUNTS => 153 +, SQL_PARAM_ARRAY_SELECTS => 154 +, SQL_POSITIONED_STATEMENTS => 80 +, SQL_POS_OPERATIONS => 79 +, SQL_PROCEDURES => 21 +, SQL_PROCEDURE_TERM => 40 +, SQL_QUALIFIER_LOCATION => 114 +, SQL_QUALIFIER_NAME_SEPARATOR => 41 +, SQL_QUALIFIER_TERM => 42 +, SQL_QUALIFIER_USAGE => 92 +, SQL_QUOTED_IDENTIFIER_CASE => 93 +, SQL_ROW_UPDATES => 11 +, SQL_SCHEMA_TERM => 39 # SQL_OWNER_TERM +, SQL_SCHEMA_USAGE => 91 # SQL_OWNER_USAGE +, SQL_SCROLL_CONCURRENCY => 43 +, SQL_SCROLL_OPTIONS => 44 +, SQL_SEARCH_PATTERN_ESCAPE => 14 +, SQL_SERVER_NAME => 13 +, SQL_SPECIAL_CHARACTERS => 94 +, SQL_SQL92_DATETIME_FUNCTIONS => 155 +, SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 156 +, SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 157 +, SQL_SQL92_GRANT => 158 +, SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 159 +, SQL_SQL92_PREDICATES => 160 +, SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 161 +, SQL_SQL92_REVOKE => 162 +, SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 163 +, SQL_SQL92_STRING_FUNCTIONS => 164 +, SQL_SQL92_VALUE_EXPRESSIONS => 165 +, SQL_SQL_CONFORMANCE => 118 +, SQL_STANDARD_CLI_CONFORMANCE => 166 +, SQL_STATIC_CURSOR_ATTRIBUTES1 => 167 +, SQL_STATIC_CURSOR_ATTRIBUTES2 => 168 +, SQL_STATIC_SENSITIVITY => 83 +, SQL_STRING_FUNCTIONS => 50 +, SQL_SUBQUERIES => 95 +, SQL_SYSTEM_FUNCTIONS => 51 +, SQL_TABLE_TERM => 45 +, SQL_TIMEDATE_ADD_INTERVALS => 109 +, SQL_TIMEDATE_DIFF_INTERVALS => 110 +, SQL_TIMEDATE_FUNCTIONS => 52 +, SQL_TRANSACTION_CAPABLE => 46 # SQL_TXN_CAPABLE +, SQL_TRANSACTION_ISOLATION_OPTION => 72 # SQL_TXN_ISOLATION_OPTION +, SQL_TXN_CAPABLE => 46 +, SQL_TXN_ISOLATION_OPTION => 72 +, SQL_UNION => 96 +, SQL_UNION_STATEMENT => 96 # SQL_UNION +, SQL_USER_NAME => 47 +, SQL_XOPEN_CLI_YEAR => 10000 +); + +#line 269 + +%ReturnTypes = +( + SQL_ACCESSIBLE_PROCEDURES => 'SQLCHAR' # 20 +, SQL_ACCESSIBLE_TABLES => 'SQLCHAR' # 19 +, SQL_ACTIVE_CONNECTIONS => 'SQLUSMALLINT' # 0 => +, SQL_ACTIVE_ENVIRONMENTS => 'SQLUSMALLINT' # 116 +, SQL_ACTIVE_STATEMENTS => 'SQLUSMALLINT' # 1 => +, SQL_AGGREGATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 169 +, SQL_ALTER_DOMAIN => 'SQLUINTEGER bitmask' # 117 +, SQL_ALTER_TABLE => 'SQLUINTEGER bitmask' # 86 +, SQL_ASYNC_MODE => 'SQLUINTEGER' # 10021 +, SQL_BATCH_ROW_COUNT => 'SQLUINTEGER bitmask' # 120 +, SQL_BATCH_SUPPORT => 'SQLUINTEGER bitmask' # 121 +, SQL_BOOKMARK_PERSISTENCE => 'SQLUINTEGER bitmask' # 82 +, SQL_CATALOG_LOCATION => 'SQLUSMALLINT' # 114 +, SQL_CATALOG_NAME => 'SQLCHAR' # 10003 +, SQL_CATALOG_NAME_SEPARATOR => 'SQLCHAR' # 41 +, SQL_CATALOG_TERM => 'SQLCHAR' # 42 +, SQL_CATALOG_USAGE => 'SQLUINTEGER bitmask' # 92 +, SQL_COLLATION_SEQ => 'SQLCHAR' # 10004 +, SQL_COLUMN_ALIAS => 'SQLCHAR' # 87 +, SQL_CONCAT_NULL_BEHAVIOR => 'SQLUSMALLINT' # 22 +, SQL_CONVERT_BIGINT => 'SQLUINTEGER bitmask' # 53 +, SQL_CONVERT_BINARY => 'SQLUINTEGER bitmask' # 54 +, SQL_CONVERT_BIT => 'SQLUINTEGER bitmask' # 55 +, SQL_CONVERT_CHAR => 'SQLUINTEGER bitmask' # 56 +, SQL_CONVERT_DATE => 'SQLUINTEGER bitmask' # 57 +, SQL_CONVERT_DECIMAL => 'SQLUINTEGER bitmask' # 58 +, SQL_CONVERT_DOUBLE => 'SQLUINTEGER bitmask' # 59 +, SQL_CONVERT_FLOAT => 'SQLUINTEGER bitmask' # 60 +, SQL_CONVERT_FUNCTIONS => 'SQLUINTEGER bitmask' # 48 +, SQL_CONVERT_GUID => 'SQLUINTEGER bitmask' # 173 +, SQL_CONVERT_INTEGER => 'SQLUINTEGER bitmask' # 61 +, SQL_CONVERT_INTERVAL_DAY_TIME => 'SQLUINTEGER bitmask' # 123 +, SQL_CONVERT_INTERVAL_YEAR_MONTH => 'SQLUINTEGER bitmask' # 124 +, SQL_CONVERT_LONGVARBINARY => 'SQLUINTEGER bitmask' # 71 +, SQL_CONVERT_LONGVARCHAR => 'SQLUINTEGER bitmask' # 62 +, SQL_CONVERT_NUMERIC => 'SQLUINTEGER bitmask' # 63 +, SQL_CONVERT_REAL => 'SQLUINTEGER bitmask' # 64 +, SQL_CONVERT_SMALLINT => 'SQLUINTEGER bitmask' # 65 +, SQL_CONVERT_TIME => 'SQLUINTEGER bitmask' # 66 +, SQL_CONVERT_TIMESTAMP => 'SQLUINTEGER bitmask' # 67 +, SQL_CONVERT_TINYINT => 'SQLUINTEGER bitmask' # 68 +, SQL_CONVERT_VARBINARY => 'SQLUINTEGER bitmask' # 69 +, SQL_CONVERT_VARCHAR => 'SQLUINTEGER bitmask' # 70 +, SQL_CONVERT_WCHAR => 'SQLUINTEGER bitmask' # 122 => !!! +, SQL_CONVERT_WLONGVARCHAR => 'SQLUINTEGER bitmask' # 125 => !!! +, SQL_CONVERT_WVARCHAR => 'SQLUINTEGER bitmask' # 126 => !!! +, SQL_CORRELATION_NAME => 'SQLUSMALLINT' # 74 +, SQL_CREATE_ASSERTION => 'SQLUINTEGER bitmask' # 127 +, SQL_CREATE_CHARACTER_SET => 'SQLUINTEGER bitmask' # 128 +, SQL_CREATE_COLLATION => 'SQLUINTEGER bitmask' # 129 +, SQL_CREATE_DOMAIN => 'SQLUINTEGER bitmask' # 130 +, SQL_CREATE_SCHEMA => 'SQLUINTEGER bitmask' # 131 +, SQL_CREATE_TABLE => 'SQLUINTEGER bitmask' # 132 +, SQL_CREATE_TRANSLATION => 'SQLUINTEGER bitmask' # 133 +, SQL_CREATE_VIEW => 'SQLUINTEGER bitmask' # 134 +, SQL_CURSOR_COMMIT_BEHAVIOR => 'SQLUSMALLINT' # 23 +, SQL_CURSOR_ROLLBACK_BEHAVIOR => 'SQLUSMALLINT' # 24 +, SQL_CURSOR_SENSITIVITY => 'SQLUINTEGER' # 10001 +, SQL_DATA_SOURCE_NAME => 'SQLCHAR' # 2 +, SQL_DATA_SOURCE_READ_ONLY => 'SQLCHAR' # 25 +, SQL_DATABASE_NAME => 'SQLCHAR' # 16 +, SQL_DATETIME_LITERALS => 'SQLUINTEGER bitmask' # 119 +, SQL_DBMS_NAME => 'SQLCHAR' # 17 +, SQL_DBMS_VER => 'SQLCHAR' # 18 +, SQL_DDL_INDEX => 'SQLUINTEGER bitmask' # 170 +, SQL_DEFAULT_TXN_ISOLATION => 'SQLUINTEGER' # 26 +, SQL_DESCRIBE_PARAMETER => 'SQLCHAR' # 10002 +, SQL_DM_VER => 'SQLCHAR' # 171 +, SQL_DRIVER_HDBC => 'SQLUINTEGER' # 3 +, SQL_DRIVER_HDESC => 'SQLUINTEGER' # 135 +, SQL_DRIVER_HENV => 'SQLUINTEGER' # 4 +, SQL_DRIVER_HLIB => 'SQLUINTEGER' # 76 +, SQL_DRIVER_HSTMT => 'SQLUINTEGER' # 5 +, SQL_DRIVER_NAME => 'SQLCHAR' # 6 +, SQL_DRIVER_ODBC_VER => 'SQLCHAR' # 77 +, SQL_DRIVER_VER => 'SQLCHAR' # 7 +, SQL_DROP_ASSERTION => 'SQLUINTEGER bitmask' # 136 +, SQL_DROP_CHARACTER_SET => 'SQLUINTEGER bitmask' # 137 +, SQL_DROP_COLLATION => 'SQLUINTEGER bitmask' # 138 +, SQL_DROP_DOMAIN => 'SQLUINTEGER bitmask' # 139 +, SQL_DROP_SCHEMA => 'SQLUINTEGER bitmask' # 140 +, SQL_DROP_TABLE => 'SQLUINTEGER bitmask' # 141 +, SQL_DROP_TRANSLATION => 'SQLUINTEGER bitmask' # 142 +, SQL_DROP_VIEW => 'SQLUINTEGER bitmask' # 143 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 144 +, SQL_DYNAMIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 145 +, SQL_EXPRESSIONS_IN_ORDERBY => 'SQLCHAR' # 27 +, SQL_FETCH_DIRECTION => 'SQLUINTEGER bitmask' # 8 => !!! +, SQL_FILE_USAGE => 'SQLUSMALLINT' # 84 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 146 +, SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 147 +, SQL_GETDATA_EXTENSIONS => 'SQLUINTEGER bitmask' # 81 +, SQL_GROUP_BY => 'SQLUSMALLINT' # 88 +, SQL_IDENTIFIER_CASE => 'SQLUSMALLINT' # 28 +, SQL_IDENTIFIER_QUOTE_CHAR => 'SQLCHAR' # 29 +, SQL_INDEX_KEYWORDS => 'SQLUINTEGER bitmask' # 148 +# SQL_INFO_DRIVER_START => '' # 1000 => +# SQL_INFO_FIRST => 'SQLUSMALLINT' # 0 => +# SQL_INFO_LAST => 'SQLUSMALLINT' # 114 => +, SQL_INFO_SCHEMA_VIEWS => 'SQLUINTEGER bitmask' # 149 +, SQL_INSERT_STATEMENT => 'SQLUINTEGER bitmask' # 172 +, SQL_INTEGRITY => 'SQLCHAR' # 73 +, SQL_KEYSET_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 150 +, SQL_KEYSET_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 151 +, SQL_KEYWORDS => 'SQLCHAR' # 89 +, SQL_LIKE_ESCAPE_CLAUSE => 'SQLCHAR' # 113 +, SQL_LOCK_TYPES => 'SQLUINTEGER bitmask' # 78 => !!! +, SQL_MAXIMUM_CATALOG_NAME_LENGTH => 'SQLUSMALLINT' # 34 => +, SQL_MAXIMUM_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 => +, SQL_MAXIMUM_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 => +, SQL_MAXIMUM_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 => +, SQL_MAXIMUM_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 => +, SQL_MAXIMUM_COLUMN_NAME_LENGTH => 'SQLUSMALLINT' # 30 => +, SQL_MAXIMUM_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 => +, SQL_MAXIMUM_CURSOR_NAME_LENGTH => 'SQLUSMALLINT' # 31 => +, SQL_MAXIMUM_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 => +, SQL_MAXIMUM_IDENTIFIER_LENGTH => 'SQLUSMALLINT' # 10005 => +, SQL_MAXIMUM_INDEX_SIZE => 'SQLUINTEGER' # 102 => +, SQL_MAXIMUM_ROW_SIZE => 'SQLUINTEGER' # 104 => +, SQL_MAXIMUM_SCHEMA_NAME_LENGTH => 'SQLUSMALLINT' # 32 => +, SQL_MAXIMUM_STATEMENT_LENGTH => 'SQLUINTEGER' # 105 => +, SQL_MAXIMUM_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 => +, SQL_MAXIMUM_USER_NAME_LENGTH => 'SQLUSMALLINT' # 107 => +, SQL_MAX_ASYNC_CONCURRENT_STATEMENTS => 'SQLUINTEGER' # 10022 +, SQL_MAX_BINARY_LITERAL_LEN => 'SQLUINTEGER' # 112 +, SQL_MAX_CATALOG_NAME_LEN => 'SQLUSMALLINT' # 34 +, SQL_MAX_CHAR_LITERAL_LEN => 'SQLUINTEGER' # 108 +, SQL_MAX_COLUMNS_IN_GROUP_BY => 'SQLUSMALLINT' # 97 +, SQL_MAX_COLUMNS_IN_INDEX => 'SQLUSMALLINT' # 98 +, SQL_MAX_COLUMNS_IN_ORDER_BY => 'SQLUSMALLINT' # 99 +, SQL_MAX_COLUMNS_IN_SELECT => 'SQLUSMALLINT' # 100 +, SQL_MAX_COLUMNS_IN_TABLE => 'SQLUSMALLINT' # 101 +, SQL_MAX_COLUMN_NAME_LEN => 'SQLUSMALLINT' # 30 +, SQL_MAX_CONCURRENT_ACTIVITIES => 'SQLUSMALLINT' # 1 +, SQL_MAX_CURSOR_NAME_LEN => 'SQLUSMALLINT' # 31 +, SQL_MAX_DRIVER_CONNECTIONS => 'SQLUSMALLINT' # 0 +, SQL_MAX_IDENTIFIER_LEN => 'SQLUSMALLINT' # 10005 +, SQL_MAX_INDEX_SIZE => 'SQLUINTEGER' # 102 +, SQL_MAX_OWNER_NAME_LEN => 'SQLUSMALLINT' # 32 => +, SQL_MAX_PROCEDURE_NAME_LEN => 'SQLUSMALLINT' # 33 +, SQL_MAX_QUALIFIER_NAME_LEN => 'SQLUSMALLINT' # 34 => +, SQL_MAX_ROW_SIZE => 'SQLUINTEGER' # 104 +, SQL_MAX_ROW_SIZE_INCLUDES_LONG => 'SQLCHAR' # 103 +, SQL_MAX_SCHEMA_NAME_LEN => 'SQLUSMALLINT' # 32 +, SQL_MAX_STATEMENT_LEN => 'SQLUINTEGER' # 105 +, SQL_MAX_TABLES_IN_SELECT => 'SQLUSMALLINT' # 106 +, SQL_MAX_TABLE_NAME_LEN => 'SQLUSMALLINT' # 35 +, SQL_MAX_USER_NAME_LEN => 'SQLUSMALLINT' # 107 +, SQL_MULTIPLE_ACTIVE_TXN => 'SQLCHAR' # 37 +, SQL_MULT_RESULT_SETS => 'SQLCHAR' # 36 +, SQL_NEED_LONG_DATA_LEN => 'SQLCHAR' # 111 +, SQL_NON_NULLABLE_COLUMNS => 'SQLUSMALLINT' # 75 +, SQL_NULL_COLLATION => 'SQLUSMALLINT' # 85 +, SQL_NUMERIC_FUNCTIONS => 'SQLUINTEGER bitmask' # 49 +, SQL_ODBC_API_CONFORMANCE => 'SQLUSMALLINT' # 9 => !!! +, SQL_ODBC_INTERFACE_CONFORMANCE => 'SQLUINTEGER' # 152 +, SQL_ODBC_SAG_CLI_CONFORMANCE => 'SQLUSMALLINT' # 12 => !!! +, SQL_ODBC_SQL_CONFORMANCE => 'SQLUSMALLINT' # 15 => !!! +, SQL_ODBC_SQL_OPT_IEF => 'SQLCHAR' # 73 => +, SQL_ODBC_VER => 'SQLCHAR' # 10 +, SQL_OJ_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 +, SQL_ORDER_BY_COLUMNS_IN_SELECT => 'SQLCHAR' # 90 +, SQL_OUTER_JOINS => 'SQLCHAR' # 38 => !!! +, SQL_OUTER_JOIN_CAPABILITIES => 'SQLUINTEGER bitmask' # 115 => +, SQL_OWNER_TERM => 'SQLCHAR' # 39 => +, SQL_OWNER_USAGE => 'SQLUINTEGER bitmask' # 91 => +, SQL_PARAM_ARRAY_ROW_COUNTS => 'SQLUINTEGER' # 153 +, SQL_PARAM_ARRAY_SELECTS => 'SQLUINTEGER' # 154 +, SQL_POSITIONED_STATEMENTS => 'SQLUINTEGER bitmask' # 80 => !!! +, SQL_POS_OPERATIONS => 'SQLINTEGER bitmask' # 79 +, SQL_PROCEDURES => 'SQLCHAR' # 21 +, SQL_PROCEDURE_TERM => 'SQLCHAR' # 40 +, SQL_QUALIFIER_LOCATION => 'SQLUSMALLINT' # 114 => +, SQL_QUALIFIER_NAME_SEPARATOR => 'SQLCHAR' # 41 => +, SQL_QUALIFIER_TERM => 'SQLCHAR' # 42 => +, SQL_QUALIFIER_USAGE => 'SQLUINTEGER bitmask' # 92 => +, SQL_QUOTED_IDENTIFIER_CASE => 'SQLUSMALLINT' # 93 +, SQL_ROW_UPDATES => 'SQLCHAR' # 11 +, SQL_SCHEMA_TERM => 'SQLCHAR' # 39 +, SQL_SCHEMA_USAGE => 'SQLUINTEGER bitmask' # 91 +, SQL_SCROLL_CONCURRENCY => 'SQLUINTEGER bitmask' # 43 => !!! +, SQL_SCROLL_OPTIONS => 'SQLUINTEGER bitmask' # 44 +, SQL_SEARCH_PATTERN_ESCAPE => 'SQLCHAR' # 14 +, SQL_SERVER_NAME => 'SQLCHAR' # 13 +, SQL_SPECIAL_CHARACTERS => 'SQLCHAR' # 94 +, SQL_SQL92_DATETIME_FUNCTIONS => 'SQLUINTEGER bitmask' # 155 +, SQL_SQL92_FOREIGN_KEY_DELETE_RULE => 'SQLUINTEGER bitmask' # 156 +, SQL_SQL92_FOREIGN_KEY_UPDATE_RULE => 'SQLUINTEGER bitmask' # 157 +, SQL_SQL92_GRANT => 'SQLUINTEGER bitmask' # 158 +, SQL_SQL92_NUMERIC_VALUE_FUNCTIONS => 'SQLUINTEGER bitmask' # 159 +, SQL_SQL92_PREDICATES => 'SQLUINTEGER bitmask' # 160 +, SQL_SQL92_RELATIONAL_JOIN_OPERATORS => 'SQLUINTEGER bitmask' # 161 +, SQL_SQL92_REVOKE => 'SQLUINTEGER bitmask' # 162 +, SQL_SQL92_ROW_VALUE_CONSTRUCTOR => 'SQLUINTEGER bitmask' # 163 +, SQL_SQL92_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 164 +, SQL_SQL92_VALUE_EXPRESSIONS => 'SQLUINTEGER bitmask' # 165 +, SQL_SQL_CONFORMANCE => 'SQLUINTEGER' # 118 +, SQL_STANDARD_CLI_CONFORMANCE => 'SQLUINTEGER bitmask' # 166 +, SQL_STATIC_CURSOR_ATTRIBUTES1 => 'SQLUINTEGER bitmask' # 167 +, SQL_STATIC_CURSOR_ATTRIBUTES2 => 'SQLUINTEGER bitmask' # 168 +, SQL_STATIC_SENSITIVITY => 'SQLUINTEGER bitmask' # 83 => !!! +, SQL_STRING_FUNCTIONS => 'SQLUINTEGER bitmask' # 50 +, SQL_SUBQUERIES => 'SQLUINTEGER bitmask' # 95 +, SQL_SYSTEM_FUNCTIONS => 'SQLUINTEGER bitmask' # 51 +, SQL_TABLE_TERM => 'SQLCHAR' # 45 +, SQL_TIMEDATE_ADD_INTERVALS => 'SQLUINTEGER bitmask' # 109 +, SQL_TIMEDATE_DIFF_INTERVALS => 'SQLUINTEGER bitmask' # 110 +, SQL_TIMEDATE_FUNCTIONS => 'SQLUINTEGER bitmask' # 52 +, SQL_TRANSACTION_CAPABLE => 'SQLUSMALLINT' # 46 => +, SQL_TRANSACTION_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 => +, SQL_TXN_CAPABLE => 'SQLUSMALLINT' # 46 +, SQL_TXN_ISOLATION_OPTION => 'SQLUINTEGER bitmask' # 72 +, SQL_UNION => 'SQLUINTEGER bitmask' # 96 +, SQL_UNION_STATEMENT => 'SQLUINTEGER bitmask' # 96 => +, SQL_USER_NAME => 'SQLCHAR' # 47 +, SQL_XOPEN_CLI_YEAR => 'SQLCHAR' # 10000 +); + +#line 497 + +$ReturnValues{SQL_AGGREGATE_FUNCTIONS} = +{ + SQL_AF_AVG => 0x00000001 +, SQL_AF_COUNT => 0x00000002 +, SQL_AF_MAX => 0x00000004 +, SQL_AF_MIN => 0x00000008 +, SQL_AF_SUM => 0x00000010 +, SQL_AF_DISTINCT => 0x00000020 +, SQL_AF_ALL => 0x00000040 +}; +$ReturnValues{SQL_ALTER_DOMAIN} = +{ + SQL_AD_CONSTRAINT_NAME_DEFINITION => 0x00000001 +, SQL_AD_ADD_DOMAIN_CONSTRAINT => 0x00000002 +, SQL_AD_DROP_DOMAIN_CONSTRAINT => 0x00000004 +, SQL_AD_ADD_DOMAIN_DEFAULT => 0x00000008 +, SQL_AD_DROP_DOMAIN_DEFAULT => 0x00000010 +, SQL_AD_ADD_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 +, SQL_AD_ADD_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 +, SQL_AD_ADD_CONSTRAINT_DEFERRABLE => 0x00000080 +, SQL_AD_ADD_CONSTRAINT_NON_DEFERRABLE => 0x00000100 +}; +$ReturnValues{SQL_ALTER_TABLE} = +{ + SQL_AT_ADD_COLUMN => 0x00000001 +, SQL_AT_DROP_COLUMN => 0x00000002 +, SQL_AT_ADD_CONSTRAINT => 0x00000008 +, SQL_AT_ADD_COLUMN_SINGLE => 0x00000020 +, SQL_AT_ADD_COLUMN_DEFAULT => 0x00000040 +, SQL_AT_ADD_COLUMN_COLLATION => 0x00000080 +, SQL_AT_SET_COLUMN_DEFAULT => 0x00000100 +, SQL_AT_DROP_COLUMN_DEFAULT => 0x00000200 +, SQL_AT_DROP_COLUMN_CASCADE => 0x00000400 +, SQL_AT_DROP_COLUMN_RESTRICT => 0x00000800 +, SQL_AT_ADD_TABLE_CONSTRAINT => 0x00001000 +, SQL_AT_DROP_TABLE_CONSTRAINT_CASCADE => 0x00002000 +, SQL_AT_DROP_TABLE_CONSTRAINT_RESTRICT => 0x00004000 +, SQL_AT_CONSTRAINT_NAME_DEFINITION => 0x00008000 +, SQL_AT_CONSTRAINT_INITIALLY_DEFERRED => 0x00010000 +, SQL_AT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00020000 +, SQL_AT_CONSTRAINT_DEFERRABLE => 0x00040000 +, SQL_AT_CONSTRAINT_NON_DEFERRABLE => 0x00080000 +}; +$ReturnValues{SQL_ASYNC_MODE} = +{ + SQL_AM_NONE => 0 +, SQL_AM_CONNECTION => 1 +, SQL_AM_STATEMENT => 2 +}; +$ReturnValues{SQL_ATTR_MAX_ROWS} = +{ + SQL_CA2_MAX_ROWS_SELECT => 0x00000080 +, SQL_CA2_MAX_ROWS_INSERT => 0x00000100 +, SQL_CA2_MAX_ROWS_DELETE => 0x00000200 +, SQL_CA2_MAX_ROWS_UPDATE => 0x00000400 +, SQL_CA2_MAX_ROWS_CATALOG => 0x00000800 +# SQL_CA2_MAX_ROWS_AFFECTS_ALL => +}; +$ReturnValues{SQL_ATTR_SCROLL_CONCURRENCY} = +{ + SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001 +, SQL_CA2_LOCK_CONCURRENCY => 0x00000002 +, SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004 +, SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008 +, SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010 +, SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020 +, SQL_CA2_SENSITIVITY_UPDATES => 0x00000040 +}; +$ReturnValues{SQL_BATCH_ROW_COUNT} = +{ + SQL_BRC_PROCEDURES => 0x0000001 +, SQL_BRC_EXPLICIT => 0x0000002 +, SQL_BRC_ROLLED_UP => 0x0000004 +}; +$ReturnValues{SQL_BATCH_SUPPORT} = +{ + SQL_BS_SELECT_EXPLICIT => 0x00000001 +, SQL_BS_ROW_COUNT_EXPLICIT => 0x00000002 +, SQL_BS_SELECT_PROC => 0x00000004 +, SQL_BS_ROW_COUNT_PROC => 0x00000008 +}; +$ReturnValues{SQL_BOOKMARK_PERSISTENCE} = +{ + SQL_BP_CLOSE => 0x00000001 +, SQL_BP_DELETE => 0x00000002 +, SQL_BP_DROP => 0x00000004 +, SQL_BP_TRANSACTION => 0x00000008 +, SQL_BP_UPDATE => 0x00000010 +, SQL_BP_OTHER_HSTMT => 0x00000020 +, SQL_BP_SCROLL => 0x00000040 +}; +$ReturnValues{SQL_CATALOG_LOCATION} = +{ + SQL_CL_START => 0x0001 # SQL_QL_START +, SQL_CL_END => 0x0002 # SQL_QL_END +}; +$ReturnValues{SQL_CATALOG_USAGE} = +{ + SQL_CU_DML_STATEMENTS => 0x00000001 # SQL_QU_DML_STATEMENTS +, SQL_CU_PROCEDURE_INVOCATION => 0x00000002 # SQL_QU_PROCEDURE_INVOCATION +, SQL_CU_TABLE_DEFINITION => 0x00000004 # SQL_QU_TABLE_DEFINITION +, SQL_CU_INDEX_DEFINITION => 0x00000008 # SQL_QU_INDEX_DEFINITION +, SQL_CU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_QU_PRIVILEGE_DEFINITION +}; +$ReturnValues{SQL_CONCAT_NULL_BEHAVIOR} = +{ + SQL_CB_NULL => 0x0000 +, SQL_CB_NON_NULL => 0x0001 +}; +$ReturnValues{SQL_CONVERT_} = +{ + SQL_CVT_CHAR => 0x00000001 +, SQL_CVT_NUMERIC => 0x00000002 +, SQL_CVT_DECIMAL => 0x00000004 +, SQL_CVT_INTEGER => 0x00000008 +, SQL_CVT_SMALLINT => 0x00000010 +, SQL_CVT_FLOAT => 0x00000020 +, SQL_CVT_REAL => 0x00000040 +, SQL_CVT_DOUBLE => 0x00000080 +, SQL_CVT_VARCHAR => 0x00000100 +, SQL_CVT_LONGVARCHAR => 0x00000200 +, SQL_CVT_BINARY => 0x00000400 +, SQL_CVT_VARBINARY => 0x00000800 +, SQL_CVT_BIT => 0x00001000 +, SQL_CVT_TINYINT => 0x00002000 +, SQL_CVT_BIGINT => 0x00004000 +, SQL_CVT_DATE => 0x00008000 +, SQL_CVT_TIME => 0x00010000 +, SQL_CVT_TIMESTAMP => 0x00020000 +, SQL_CVT_LONGVARBINARY => 0x00040000 +, SQL_CVT_INTERVAL_YEAR_MONTH => 0x00080000 +, SQL_CVT_INTERVAL_DAY_TIME => 0x00100000 +, SQL_CVT_WCHAR => 0x00200000 +, SQL_CVT_WLONGVARCHAR => 0x00400000 +, SQL_CVT_WVARCHAR => 0x00800000 +, SQL_CVT_GUID => 0x01000000 +}; +$ReturnValues{SQL_CONVERT_BIGINT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_BINARY } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_BIT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_CHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_DATE } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_DECIMAL } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_DOUBLE } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_FLOAT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_GUID } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_INTEGER } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_INTERVAL_DAY_TIME } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_INTERVAL_YEAR_MONTH} = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_LONGVARBINARY } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_LONGVARCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_NUMERIC } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_REAL } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_SMALLINT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_TIME } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_TIMESTAMP } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_TINYINT } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_VARBINARY } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_VARCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_WCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_WLONGVARCHAR } = $ReturnValues{SQL_CONVERT_}; +$ReturnValues{SQL_CONVERT_WVARCHAR } = $ReturnValues{SQL_CONVERT_}; + +$ReturnValues{SQL_CONVERT_FUNCTIONS} = +{ + SQL_FN_CVT_CONVERT => 0x00000001 +, SQL_FN_CVT_CAST => 0x00000002 +}; +$ReturnValues{SQL_CORRELATION_NAME} = +{ + SQL_CN_NONE => 0x0000 +, SQL_CN_DIFFERENT => 0x0001 +, SQL_CN_ANY => 0x0002 +}; +$ReturnValues{SQL_CREATE_ASSERTION} = +{ + SQL_CA_CREATE_ASSERTION => 0x00000001 +, SQL_CA_CONSTRAINT_INITIALLY_DEFERRED => 0x00000010 +, SQL_CA_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000020 +, SQL_CA_CONSTRAINT_DEFERRABLE => 0x00000040 +, SQL_CA_CONSTRAINT_NON_DEFERRABLE => 0x00000080 +}; +$ReturnValues{SQL_CREATE_CHARACTER_SET} = +{ + SQL_CCS_CREATE_CHARACTER_SET => 0x00000001 +, SQL_CCS_COLLATE_CLAUSE => 0x00000002 +, SQL_CCS_LIMITED_COLLATION => 0x00000004 +}; +$ReturnValues{SQL_CREATE_COLLATION} = +{ + SQL_CCOL_CREATE_COLLATION => 0x00000001 +}; +$ReturnValues{SQL_CREATE_DOMAIN} = +{ + SQL_CDO_CREATE_DOMAIN => 0x00000001 +, SQL_CDO_DEFAULT => 0x00000002 +, SQL_CDO_CONSTRAINT => 0x00000004 +, SQL_CDO_COLLATION => 0x00000008 +, SQL_CDO_CONSTRAINT_NAME_DEFINITION => 0x00000010 +, SQL_CDO_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 +, SQL_CDO_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 +, SQL_CDO_CONSTRAINT_DEFERRABLE => 0x00000080 +, SQL_CDO_CONSTRAINT_NON_DEFERRABLE => 0x00000100 +}; +$ReturnValues{SQL_CREATE_SCHEMA} = +{ + SQL_CS_CREATE_SCHEMA => 0x00000001 +, SQL_CS_AUTHORIZATION => 0x00000002 +, SQL_CS_DEFAULT_CHARACTER_SET => 0x00000004 +}; +$ReturnValues{SQL_CREATE_TABLE} = +{ + SQL_CT_CREATE_TABLE => 0x00000001 +, SQL_CT_COMMIT_PRESERVE => 0x00000002 +, SQL_CT_COMMIT_DELETE => 0x00000004 +, SQL_CT_GLOBAL_TEMPORARY => 0x00000008 +, SQL_CT_LOCAL_TEMPORARY => 0x00000010 +, SQL_CT_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 +, SQL_CT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 +, SQL_CT_CONSTRAINT_DEFERRABLE => 0x00000080 +, SQL_CT_CONSTRAINT_NON_DEFERRABLE => 0x00000100 +, SQL_CT_COLUMN_CONSTRAINT => 0x00000200 +, SQL_CT_COLUMN_DEFAULT => 0x00000400 +, SQL_CT_COLUMN_COLLATION => 0x00000800 +, SQL_CT_TABLE_CONSTRAINT => 0x00001000 +, SQL_CT_CONSTRAINT_NAME_DEFINITION => 0x00002000 +}; +$ReturnValues{SQL_CREATE_TRANSLATION} = +{ + SQL_CTR_CREATE_TRANSLATION => 0x00000001 +}; +$ReturnValues{SQL_CREATE_VIEW} = +{ + SQL_CV_CREATE_VIEW => 0x00000001 +, SQL_CV_CHECK_OPTION => 0x00000002 +, SQL_CV_CASCADED => 0x00000004 +, SQL_CV_LOCAL => 0x00000008 +}; +$ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR} = +{ + SQL_CB_DELETE => 0 +, SQL_CB_CLOSE => 1 +, SQL_CB_PRESERVE => 2 +}; +$ReturnValues{SQL_CURSOR_ROLLBACK_BEHAVIOR} = $ReturnValues{SQL_CURSOR_COMMIT_BEHAVIOR}; + +$ReturnValues{SQL_CURSOR_SENSITIVITY} = +{ + SQL_UNSPECIFIED => 0 +, SQL_INSENSITIVE => 1 +, SQL_SENSITIVE => 2 +}; +$ReturnValues{SQL_DATETIME_LITERALS} = +{ + SQL_DL_SQL92_DATE => 0x00000001 +, SQL_DL_SQL92_TIME => 0x00000002 +, SQL_DL_SQL92_TIMESTAMP => 0x00000004 +, SQL_DL_SQL92_INTERVAL_YEAR => 0x00000008 +, SQL_DL_SQL92_INTERVAL_MONTH => 0x00000010 +, SQL_DL_SQL92_INTERVAL_DAY => 0x00000020 +, SQL_DL_SQL92_INTERVAL_HOUR => 0x00000040 +, SQL_DL_SQL92_INTERVAL_MINUTE => 0x00000080 +, SQL_DL_SQL92_INTERVAL_SECOND => 0x00000100 +, SQL_DL_SQL92_INTERVAL_YEAR_TO_MONTH => 0x00000200 +, SQL_DL_SQL92_INTERVAL_DAY_TO_HOUR => 0x00000400 +, SQL_DL_SQL92_INTERVAL_DAY_TO_MINUTE => 0x00000800 +, SQL_DL_SQL92_INTERVAL_DAY_TO_SECOND => 0x00001000 +, SQL_DL_SQL92_INTERVAL_HOUR_TO_MINUTE => 0x00002000 +, SQL_DL_SQL92_INTERVAL_HOUR_TO_SECOND => 0x00004000 +, SQL_DL_SQL92_INTERVAL_MINUTE_TO_SECOND => 0x00008000 +}; +$ReturnValues{SQL_DDL_INDEX} = +{ + SQL_DI_CREATE_INDEX => 0x00000001 +, SQL_DI_DROP_INDEX => 0x00000002 +}; +$ReturnValues{SQL_DIAG_CURSOR_ROW_COUNT} = +{ + SQL_CA2_CRC_EXACT => 0x00001000 +, SQL_CA2_CRC_APPROXIMATE => 0x00002000 +, SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000 +, SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000 +, SQL_CA2_SIMULATE_UNIQUE => 0x00010000 +}; +$ReturnValues{SQL_DROP_ASSERTION} = +{ + SQL_DA_DROP_ASSERTION => 0x00000001 +}; +$ReturnValues{SQL_DROP_CHARACTER_SET} = +{ + SQL_DCS_DROP_CHARACTER_SET => 0x00000001 +}; +$ReturnValues{SQL_DROP_COLLATION} = +{ + SQL_DC_DROP_COLLATION => 0x00000001 +}; +$ReturnValues{SQL_DROP_DOMAIN} = +{ + SQL_DD_DROP_DOMAIN => 0x00000001 +, SQL_DD_RESTRICT => 0x00000002 +, SQL_DD_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_DROP_SCHEMA} = +{ + SQL_DS_DROP_SCHEMA => 0x00000001 +, SQL_DS_RESTRICT => 0x00000002 +, SQL_DS_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_DROP_TABLE} = +{ + SQL_DT_DROP_TABLE => 0x00000001 +, SQL_DT_RESTRICT => 0x00000002 +, SQL_DT_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_DROP_TRANSLATION} = +{ + SQL_DTR_DROP_TRANSLATION => 0x00000001 +}; +$ReturnValues{SQL_DROP_VIEW} = +{ + SQL_DV_DROP_VIEW => 0x00000001 +, SQL_DV_RESTRICT => 0x00000002 +, SQL_DV_CASCADE => 0x00000004 +}; +$ReturnValues{SQL_CURSOR_ATTRIBUTES1} = +{ + SQL_CA1_NEXT => 0x00000001 +, SQL_CA1_ABSOLUTE => 0x00000002 +, SQL_CA1_RELATIVE => 0x00000004 +, SQL_CA1_BOOKMARK => 0x00000008 +, SQL_CA1_LOCK_NO_CHANGE => 0x00000040 +, SQL_CA1_LOCK_EXCLUSIVE => 0x00000080 +, SQL_CA1_LOCK_UNLOCK => 0x00000100 +, SQL_CA1_POS_POSITION => 0x00000200 +, SQL_CA1_POS_UPDATE => 0x00000400 +, SQL_CA1_POS_DELETE => 0x00000800 +, SQL_CA1_POS_REFRESH => 0x00001000 +, SQL_CA1_POSITIONED_UPDATE => 0x00002000 +, SQL_CA1_POSITIONED_DELETE => 0x00004000 +, SQL_CA1_SELECT_FOR_UPDATE => 0x00008000 +, SQL_CA1_BULK_ADD => 0x00010000 +, SQL_CA1_BULK_UPDATE_BY_BOOKMARK => 0x00020000 +, SQL_CA1_BULK_DELETE_BY_BOOKMARK => 0x00040000 +, SQL_CA1_BULK_FETCH_BY_BOOKMARK => 0x00080000 +}; +$ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; +$ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; +$ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; +$ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES1} = $ReturnValues{SQL_CURSOR_ATTRIBUTES1}; + +$ReturnValues{SQL_CURSOR_ATTRIBUTES2} = +{ + SQL_CA2_READ_ONLY_CONCURRENCY => 0x00000001 +, SQL_CA2_LOCK_CONCURRENCY => 0x00000002 +, SQL_CA2_OPT_ROWVER_CONCURRENCY => 0x00000004 +, SQL_CA2_OPT_VALUES_CONCURRENCY => 0x00000008 +, SQL_CA2_SENSITIVITY_ADDITIONS => 0x00000010 +, SQL_CA2_SENSITIVITY_DELETIONS => 0x00000020 +, SQL_CA2_SENSITIVITY_UPDATES => 0x00000040 +, SQL_CA2_MAX_ROWS_SELECT => 0x00000080 +, SQL_CA2_MAX_ROWS_INSERT => 0x00000100 +, SQL_CA2_MAX_ROWS_DELETE => 0x00000200 +, SQL_CA2_MAX_ROWS_UPDATE => 0x00000400 +, SQL_CA2_MAX_ROWS_CATALOG => 0x00000800 +, SQL_CA2_CRC_EXACT => 0x00001000 +, SQL_CA2_CRC_APPROXIMATE => 0x00002000 +, SQL_CA2_SIMULATE_NON_UNIQUE => 0x00004000 +, SQL_CA2_SIMULATE_TRY_UNIQUE => 0x00008000 +, SQL_CA2_SIMULATE_UNIQUE => 0x00010000 +}; +$ReturnValues{ SQL_DYNAMIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; +$ReturnValues{SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; +$ReturnValues{ SQL_KEYSET_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; +$ReturnValues{ SQL_STATIC_CURSOR_ATTRIBUTES2} = $ReturnValues{SQL_CURSOR_ATTRIBUTES2}; + +$ReturnValues{SQL_FETCH_DIRECTION} = +{ + SQL_FD_FETCH_NEXT => 0x00000001 +, SQL_FD_FETCH_FIRST => 0x00000002 +, SQL_FD_FETCH_LAST => 0x00000004 +, SQL_FD_FETCH_PRIOR => 0x00000008 +, SQL_FD_FETCH_ABSOLUTE => 0x00000010 +, SQL_FD_FETCH_RELATIVE => 0x00000020 +, SQL_FD_FETCH_RESUME => 0x00000040 +, SQL_FD_FETCH_BOOKMARK => 0x00000080 +}; +$ReturnValues{SQL_FILE_USAGE} = +{ + SQL_FILE_NOT_SUPPORTED => 0x0000 +, SQL_FILE_TABLE => 0x0001 +, SQL_FILE_QUALIFIER => 0x0002 +, SQL_FILE_CATALOG => 0x0002 # SQL_FILE_QUALIFIER +}; +$ReturnValues{SQL_GETDATA_EXTENSIONS} = +{ + SQL_GD_ANY_COLUMN => 0x00000001 +, SQL_GD_ANY_ORDER => 0x00000002 +, SQL_GD_BLOCK => 0x00000004 +, SQL_GD_BOUND => 0x00000008 +}; +$ReturnValues{SQL_GROUP_BY} = +{ + SQL_GB_NOT_SUPPORTED => 0x0000 +, SQL_GB_GROUP_BY_EQUALS_SELECT => 0x0001 +, SQL_GB_GROUP_BY_CONTAINS_SELECT => 0x0002 +, SQL_GB_NO_RELATION => 0x0003 +, SQL_GB_COLLATE => 0x0004 +}; +$ReturnValues{SQL_IDENTIFIER_CASE} = +{ + SQL_IC_UPPER => 1 +, SQL_IC_LOWER => 2 +, SQL_IC_SENSITIVE => 3 +, SQL_IC_MIXED => 4 +}; +$ReturnValues{SQL_INDEX_KEYWORDS} = +{ + SQL_IK_NONE => 0x00000000 +, SQL_IK_ASC => 0x00000001 +, SQL_IK_DESC => 0x00000002 +# SQL_IK_ALL => +}; +$ReturnValues{SQL_INFO_SCHEMA_VIEWS} = +{ + SQL_ISV_ASSERTIONS => 0x00000001 +, SQL_ISV_CHARACTER_SETS => 0x00000002 +, SQL_ISV_CHECK_CONSTRAINTS => 0x00000004 +, SQL_ISV_COLLATIONS => 0x00000008 +, SQL_ISV_COLUMN_DOMAIN_USAGE => 0x00000010 +, SQL_ISV_COLUMN_PRIVILEGES => 0x00000020 +, SQL_ISV_COLUMNS => 0x00000040 +, SQL_ISV_CONSTRAINT_COLUMN_USAGE => 0x00000080 +, SQL_ISV_CONSTRAINT_TABLE_USAGE => 0x00000100 +, SQL_ISV_DOMAIN_CONSTRAINTS => 0x00000200 +, SQL_ISV_DOMAINS => 0x00000400 +, SQL_ISV_KEY_COLUMN_USAGE => 0x00000800 +, SQL_ISV_REFERENTIAL_CONSTRAINTS => 0x00001000 +, SQL_ISV_SCHEMATA => 0x00002000 +, SQL_ISV_SQL_LANGUAGES => 0x00004000 +, SQL_ISV_TABLE_CONSTRAINTS => 0x00008000 +, SQL_ISV_TABLE_PRIVILEGES => 0x00010000 +, SQL_ISV_TABLES => 0x00020000 +, SQL_ISV_TRANSLATIONS => 0x00040000 +, SQL_ISV_USAGE_PRIVILEGES => 0x00080000 +, SQL_ISV_VIEW_COLUMN_USAGE => 0x00100000 +, SQL_ISV_VIEW_TABLE_USAGE => 0x00200000 +, SQL_ISV_VIEWS => 0x00400000 +}; +$ReturnValues{SQL_INSERT_STATEMENT} = +{ + SQL_IS_INSERT_LITERALS => 0x00000001 +, SQL_IS_INSERT_SEARCHED => 0x00000002 +, SQL_IS_SELECT_INTO => 0x00000004 +}; +$ReturnValues{SQL_LOCK_TYPES} = +{ + SQL_LCK_NO_CHANGE => 0x00000001 +, SQL_LCK_EXCLUSIVE => 0x00000002 +, SQL_LCK_UNLOCK => 0x00000004 +}; +$ReturnValues{SQL_NON_NULLABLE_COLUMNS} = +{ + SQL_NNC_NULL => 0x0000 +, SQL_NNC_NON_NULL => 0x0001 +}; +$ReturnValues{SQL_NULL_COLLATION} = +{ + SQL_NC_HIGH => 0 +, SQL_NC_LOW => 1 +, SQL_NC_START => 0x0002 +, SQL_NC_END => 0x0004 +}; +$ReturnValues{SQL_NUMERIC_FUNCTIONS} = +{ + SQL_FN_NUM_ABS => 0x00000001 +, SQL_FN_NUM_ACOS => 0x00000002 +, SQL_FN_NUM_ASIN => 0x00000004 +, SQL_FN_NUM_ATAN => 0x00000008 +, SQL_FN_NUM_ATAN2 => 0x00000010 +, SQL_FN_NUM_CEILING => 0x00000020 +, SQL_FN_NUM_COS => 0x00000040 +, SQL_FN_NUM_COT => 0x00000080 +, SQL_FN_NUM_EXP => 0x00000100 +, SQL_FN_NUM_FLOOR => 0x00000200 +, SQL_FN_NUM_LOG => 0x00000400 +, SQL_FN_NUM_MOD => 0x00000800 +, SQL_FN_NUM_SIGN => 0x00001000 +, SQL_FN_NUM_SIN => 0x00002000 +, SQL_FN_NUM_SQRT => 0x00004000 +, SQL_FN_NUM_TAN => 0x00008000 +, SQL_FN_NUM_PI => 0x00010000 +, SQL_FN_NUM_RAND => 0x00020000 +, SQL_FN_NUM_DEGREES => 0x00040000 +, SQL_FN_NUM_LOG10 => 0x00080000 +, SQL_FN_NUM_POWER => 0x00100000 +, SQL_FN_NUM_RADIANS => 0x00200000 +, SQL_FN_NUM_ROUND => 0x00400000 +, SQL_FN_NUM_TRUNCATE => 0x00800000 +}; +$ReturnValues{SQL_ODBC_API_CONFORMANCE} = +{ + SQL_OAC_NONE => 0x0000 +, SQL_OAC_LEVEL1 => 0x0001 +, SQL_OAC_LEVEL2 => 0x0002 +}; +$ReturnValues{SQL_ODBC_INTERFACE_CONFORMANCE} = +{ + SQL_OIC_CORE => 1 +, SQL_OIC_LEVEL1 => 2 +, SQL_OIC_LEVEL2 => 3 +}; +$ReturnValues{SQL_ODBC_SAG_CLI_CONFORMANCE} = +{ + SQL_OSCC_NOT_COMPLIANT => 0x0000 +, SQL_OSCC_COMPLIANT => 0x0001 +}; +$ReturnValues{SQL_ODBC_SQL_CONFORMANCE} = +{ + SQL_OSC_MINIMUM => 0x0000 +, SQL_OSC_CORE => 0x0001 +, SQL_OSC_EXTENDED => 0x0002 +}; +$ReturnValues{SQL_OJ_CAPABILITIES} = +{ + SQL_OJ_LEFT => 0x00000001 +, SQL_OJ_RIGHT => 0x00000002 +, SQL_OJ_FULL => 0x00000004 +, SQL_OJ_NESTED => 0x00000008 +, SQL_OJ_NOT_ORDERED => 0x00000010 +, SQL_OJ_INNER => 0x00000020 +, SQL_OJ_ALL_COMPARISON_OPS => 0x00000040 +}; +$ReturnValues{SQL_OWNER_USAGE} = +{ + SQL_OU_DML_STATEMENTS => 0x00000001 +, SQL_OU_PROCEDURE_INVOCATION => 0x00000002 +, SQL_OU_TABLE_DEFINITION => 0x00000004 +, SQL_OU_INDEX_DEFINITION => 0x00000008 +, SQL_OU_PRIVILEGE_DEFINITION => 0x00000010 +}; +$ReturnValues{SQL_PARAM_ARRAY_ROW_COUNTS} = +{ + SQL_PARC_BATCH => 1 +, SQL_PARC_NO_BATCH => 2 +}; +$ReturnValues{SQL_PARAM_ARRAY_SELECTS} = +{ + SQL_PAS_BATCH => 1 +, SQL_PAS_NO_BATCH => 2 +, SQL_PAS_NO_SELECT => 3 +}; +$ReturnValues{SQL_POSITIONED_STATEMENTS} = +{ + SQL_PS_POSITIONED_DELETE => 0x00000001 +, SQL_PS_POSITIONED_UPDATE => 0x00000002 +, SQL_PS_SELECT_FOR_UPDATE => 0x00000004 +}; +$ReturnValues{SQL_POS_OPERATIONS} = +{ + SQL_POS_POSITION => 0x00000001 +, SQL_POS_REFRESH => 0x00000002 +, SQL_POS_UPDATE => 0x00000004 +, SQL_POS_DELETE => 0x00000008 +, SQL_POS_ADD => 0x00000010 +}; +$ReturnValues{SQL_QUALIFIER_LOCATION} = +{ + SQL_QL_START => 0x0001 +, SQL_QL_END => 0x0002 +}; +$ReturnValues{SQL_QUALIFIER_USAGE} = +{ + SQL_QU_DML_STATEMENTS => 0x00000001 +, SQL_QU_PROCEDURE_INVOCATION => 0x00000002 +, SQL_QU_TABLE_DEFINITION => 0x00000004 +, SQL_QU_INDEX_DEFINITION => 0x00000008 +, SQL_QU_PRIVILEGE_DEFINITION => 0x00000010 +}; +$ReturnValues{SQL_QUOTED_IDENTIFIER_CASE} = $ReturnValues{SQL_IDENTIFIER_CASE}; + +$ReturnValues{SQL_SCHEMA_USAGE} = +{ + SQL_SU_DML_STATEMENTS => 0x00000001 # SQL_OU_DML_STATEMENTS +, SQL_SU_PROCEDURE_INVOCATION => 0x00000002 # SQL_OU_PROCEDURE_INVOCATION +, SQL_SU_TABLE_DEFINITION => 0x00000004 # SQL_OU_TABLE_DEFINITION +, SQL_SU_INDEX_DEFINITION => 0x00000008 # SQL_OU_INDEX_DEFINITION +, SQL_SU_PRIVILEGE_DEFINITION => 0x00000010 # SQL_OU_PRIVILEGE_DEFINITION +}; +$ReturnValues{SQL_SCROLL_CONCURRENCY} = +{ + SQL_SCCO_READ_ONLY => 0x00000001 +, SQL_SCCO_LOCK => 0x00000002 +, SQL_SCCO_OPT_ROWVER => 0x00000004 +, SQL_SCCO_OPT_VALUES => 0x00000008 +}; +$ReturnValues{SQL_SCROLL_OPTIONS} = +{ + SQL_SO_FORWARD_ONLY => 0x00000001 +, SQL_SO_KEYSET_DRIVEN => 0x00000002 +, SQL_SO_DYNAMIC => 0x00000004 +, SQL_SO_MIXED => 0x00000008 +, SQL_SO_STATIC => 0x00000010 +}; +$ReturnValues{SQL_SQL92_DATETIME_FUNCTIONS} = +{ + SQL_SDF_CURRENT_DATE => 0x00000001 +, SQL_SDF_CURRENT_TIME => 0x00000002 +, SQL_SDF_CURRENT_TIMESTAMP => 0x00000004 +}; +$ReturnValues{SQL_SQL92_FOREIGN_KEY_DELETE_RULE} = +{ + SQL_SFKD_CASCADE => 0x00000001 +, SQL_SFKD_NO_ACTION => 0x00000002 +, SQL_SFKD_SET_DEFAULT => 0x00000004 +, SQL_SFKD_SET_NULL => 0x00000008 +}; +$ReturnValues{SQL_SQL92_FOREIGN_KEY_UPDATE_RULE} = +{ + SQL_SFKU_CASCADE => 0x00000001 +, SQL_SFKU_NO_ACTION => 0x00000002 +, SQL_SFKU_SET_DEFAULT => 0x00000004 +, SQL_SFKU_SET_NULL => 0x00000008 +}; +$ReturnValues{SQL_SQL92_GRANT} = +{ + SQL_SG_USAGE_ON_DOMAIN => 0x00000001 +, SQL_SG_USAGE_ON_CHARACTER_SET => 0x00000002 +, SQL_SG_USAGE_ON_COLLATION => 0x00000004 +, SQL_SG_USAGE_ON_TRANSLATION => 0x00000008 +, SQL_SG_WITH_GRANT_OPTION => 0x00000010 +, SQL_SG_DELETE_TABLE => 0x00000020 +, SQL_SG_INSERT_TABLE => 0x00000040 +, SQL_SG_INSERT_COLUMN => 0x00000080 +, SQL_SG_REFERENCES_TABLE => 0x00000100 +, SQL_SG_REFERENCES_COLUMN => 0x00000200 +, SQL_SG_SELECT_TABLE => 0x00000400 +, SQL_SG_UPDATE_TABLE => 0x00000800 +, SQL_SG_UPDATE_COLUMN => 0x00001000 +}; +$ReturnValues{SQL_SQL92_NUMERIC_VALUE_FUNCTIONS} = +{ + SQL_SNVF_BIT_LENGTH => 0x00000001 +, SQL_SNVF_CHAR_LENGTH => 0x00000002 +, SQL_SNVF_CHARACTER_LENGTH => 0x00000004 +, SQL_SNVF_EXTRACT => 0x00000008 +, SQL_SNVF_OCTET_LENGTH => 0x00000010 +, SQL_SNVF_POSITION => 0x00000020 +}; +$ReturnValues{SQL_SQL92_PREDICATES} = +{ + SQL_SP_EXISTS => 0x00000001 +, SQL_SP_ISNOTNULL => 0x00000002 +, SQL_SP_ISNULL => 0x00000004 +, SQL_SP_MATCH_FULL => 0x00000008 +, SQL_SP_MATCH_PARTIAL => 0x00000010 +, SQL_SP_MATCH_UNIQUE_FULL => 0x00000020 +, SQL_SP_MATCH_UNIQUE_PARTIAL => 0x00000040 +, SQL_SP_OVERLAPS => 0x00000080 +, SQL_SP_UNIQUE => 0x00000100 +, SQL_SP_LIKE => 0x00000200 +, SQL_SP_IN => 0x00000400 +, SQL_SP_BETWEEN => 0x00000800 +, SQL_SP_COMPARISON => 0x00001000 +, SQL_SP_QUANTIFIED_COMPARISON => 0x00002000 +}; +$ReturnValues{SQL_SQL92_RELATIONAL_JOIN_OPERATORS} = +{ + SQL_SRJO_CORRESPONDING_CLAUSE => 0x00000001 +, SQL_SRJO_CROSS_JOIN => 0x00000002 +, SQL_SRJO_EXCEPT_JOIN => 0x00000004 +, SQL_SRJO_FULL_OUTER_JOIN => 0x00000008 +, SQL_SRJO_INNER_JOIN => 0x00000010 +, SQL_SRJO_INTERSECT_JOIN => 0x00000020 +, SQL_SRJO_LEFT_OUTER_JOIN => 0x00000040 +, SQL_SRJO_NATURAL_JOIN => 0x00000080 +, SQL_SRJO_RIGHT_OUTER_JOIN => 0x00000100 +, SQL_SRJO_UNION_JOIN => 0x00000200 +}; +$ReturnValues{SQL_SQL92_REVOKE} = +{ + SQL_SR_USAGE_ON_DOMAIN => 0x00000001 +, SQL_SR_USAGE_ON_CHARACTER_SET => 0x00000002 +, SQL_SR_USAGE_ON_COLLATION => 0x00000004 +, SQL_SR_USAGE_ON_TRANSLATION => 0x00000008 +, SQL_SR_GRANT_OPTION_FOR => 0x00000010 +, SQL_SR_CASCADE => 0x00000020 +, SQL_SR_RESTRICT => 0x00000040 +, SQL_SR_DELETE_TABLE => 0x00000080 +, SQL_SR_INSERT_TABLE => 0x00000100 +, SQL_SR_INSERT_COLUMN => 0x00000200 +, SQL_SR_REFERENCES_TABLE => 0x00000400 +, SQL_SR_REFERENCES_COLUMN => 0x00000800 +, SQL_SR_SELECT_TABLE => 0x00001000 +, SQL_SR_UPDATE_TABLE => 0x00002000 +, SQL_SR_UPDATE_COLUMN => 0x00004000 +}; +$ReturnValues{SQL_SQL92_ROW_VALUE_CONSTRUCTOR} = +{ + SQL_SRVC_VALUE_EXPRESSION => 0x00000001 +, SQL_SRVC_NULL => 0x00000002 +, SQL_SRVC_DEFAULT => 0x00000004 +, SQL_SRVC_ROW_SUBQUERY => 0x00000008 +}; +$ReturnValues{SQL_SQL92_STRING_FUNCTIONS} = +{ + SQL_SSF_CONVERT => 0x00000001 +, SQL_SSF_LOWER => 0x00000002 +, SQL_SSF_UPPER => 0x00000004 +, SQL_SSF_SUBSTRING => 0x00000008 +, SQL_SSF_TRANSLATE => 0x00000010 +, SQL_SSF_TRIM_BOTH => 0x00000020 +, SQL_SSF_TRIM_LEADING => 0x00000040 +, SQL_SSF_TRIM_TRAILING => 0x00000080 +}; +$ReturnValues{SQL_SQL92_VALUE_EXPRESSIONS} = +{ + SQL_SVE_CASE => 0x00000001 +, SQL_SVE_CAST => 0x00000002 +, SQL_SVE_COALESCE => 0x00000004 +, SQL_SVE_NULLIF => 0x00000008 +}; +$ReturnValues{SQL_SQL_CONFORMANCE} = +{ + SQL_SC_SQL92_ENTRY => 0x00000001 +, SQL_SC_FIPS127_2_TRANSITIONAL => 0x00000002 +, SQL_SC_SQL92_INTERMEDIATE => 0x00000004 +, SQL_SC_SQL92_FULL => 0x00000008 +}; +$ReturnValues{SQL_STANDARD_CLI_CONFORMANCE} = +{ + SQL_SCC_XOPEN_CLI_VERSION1 => 0x00000001 +, SQL_SCC_ISO92_CLI => 0x00000002 +}; +$ReturnValues{SQL_STATIC_SENSITIVITY} = +{ + SQL_SS_ADDITIONS => 0x00000001 +, SQL_SS_DELETIONS => 0x00000002 +, SQL_SS_UPDATES => 0x00000004 +}; +$ReturnValues{SQL_STRING_FUNCTIONS} = +{ + SQL_FN_STR_CONCAT => 0x00000001 +, SQL_FN_STR_INSERT => 0x00000002 +, SQL_FN_STR_LEFT => 0x00000004 +, SQL_FN_STR_LTRIM => 0x00000008 +, SQL_FN_STR_LENGTH => 0x00000010 +, SQL_FN_STR_LOCATE => 0x00000020 +, SQL_FN_STR_LCASE => 0x00000040 +, SQL_FN_STR_REPEAT => 0x00000080 +, SQL_FN_STR_REPLACE => 0x00000100 +, SQL_FN_STR_RIGHT => 0x00000200 +, SQL_FN_STR_RTRIM => 0x00000400 +, SQL_FN_STR_SUBSTRING => 0x00000800 +, SQL_FN_STR_UCASE => 0x00001000 +, SQL_FN_STR_ASCII => 0x00002000 +, SQL_FN_STR_CHAR => 0x00004000 +, SQL_FN_STR_DIFFERENCE => 0x00008000 +, SQL_FN_STR_LOCATE_2 => 0x00010000 +, SQL_FN_STR_SOUNDEX => 0x00020000 +, SQL_FN_STR_SPACE => 0x00040000 +, SQL_FN_STR_BIT_LENGTH => 0x00080000 +, SQL_FN_STR_CHAR_LENGTH => 0x00100000 +, SQL_FN_STR_CHARACTER_LENGTH => 0x00200000 +, SQL_FN_STR_OCTET_LENGTH => 0x00400000 +, SQL_FN_STR_POSITION => 0x00800000 +}; +$ReturnValues{SQL_SUBQUERIES} = +{ + SQL_SQ_COMPARISON => 0x00000001 +, SQL_SQ_EXISTS => 0x00000002 +, SQL_SQ_IN => 0x00000004 +, SQL_SQ_QUANTIFIED => 0x00000008 +, SQL_SQ_CORRELATED_SUBQUERIES => 0x00000010 +}; +$ReturnValues{SQL_SYSTEM_FUNCTIONS} = +{ + SQL_FN_SYS_USERNAME => 0x00000001 +, SQL_FN_SYS_DBNAME => 0x00000002 +, SQL_FN_SYS_IFNULL => 0x00000004 +}; +$ReturnValues{SQL_TIMEDATE_ADD_INTERVALS} = +{ + SQL_FN_TSI_FRAC_SECOND => 0x00000001 +, SQL_FN_TSI_SECOND => 0x00000002 +, SQL_FN_TSI_MINUTE => 0x00000004 +, SQL_FN_TSI_HOUR => 0x00000008 +, SQL_FN_TSI_DAY => 0x00000010 +, SQL_FN_TSI_WEEK => 0x00000020 +, SQL_FN_TSI_MONTH => 0x00000040 +, SQL_FN_TSI_QUARTER => 0x00000080 +, SQL_FN_TSI_YEAR => 0x00000100 +}; +$ReturnValues{SQL_TIMEDATE_FUNCTIONS} = +{ + SQL_FN_TD_NOW => 0x00000001 +, SQL_FN_TD_CURDATE => 0x00000002 +, SQL_FN_TD_DAYOFMONTH => 0x00000004 +, SQL_FN_TD_DAYOFWEEK => 0x00000008 +, SQL_FN_TD_DAYOFYEAR => 0x00000010 +, SQL_FN_TD_MONTH => 0x00000020 +, SQL_FN_TD_QUARTER => 0x00000040 +, SQL_FN_TD_WEEK => 0x00000080 +, SQL_FN_TD_YEAR => 0x00000100 +, SQL_FN_TD_CURTIME => 0x00000200 +, SQL_FN_TD_HOUR => 0x00000400 +, SQL_FN_TD_MINUTE => 0x00000800 +, SQL_FN_TD_SECOND => 0x00001000 +, SQL_FN_TD_TIMESTAMPADD => 0x00002000 +, SQL_FN_TD_TIMESTAMPDIFF => 0x00004000 +, SQL_FN_TD_DAYNAME => 0x00008000 +, SQL_FN_TD_MONTHNAME => 0x00010000 +, SQL_FN_TD_CURRENT_DATE => 0x00020000 +, SQL_FN_TD_CURRENT_TIME => 0x00040000 +, SQL_FN_TD_CURRENT_TIMESTAMP => 0x00080000 +, SQL_FN_TD_EXTRACT => 0x00100000 +}; +$ReturnValues{SQL_TXN_CAPABLE} = +{ + SQL_TC_NONE => 0 +, SQL_TC_DML => 1 +, SQL_TC_ALL => 2 +, SQL_TC_DDL_COMMIT => 3 +, SQL_TC_DDL_IGNORE => 4 +}; +$ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION} = +{ + SQL_TRANSACTION_READ_UNCOMMITTED => 0x00000001 # SQL_TXN_READ_UNCOMMITTED +, SQL_TRANSACTION_READ_COMMITTED => 0x00000002 # SQL_TXN_READ_COMMITTED +, SQL_TRANSACTION_REPEATABLE_READ => 0x00000004 # SQL_TXN_REPEATABLE_READ +, SQL_TRANSACTION_SERIALIZABLE => 0x00000008 # SQL_TXN_SERIALIZABLE +}; +$ReturnValues{SQL_DEFAULT_TRANSACTION_ISOLATION} = $ReturnValues{SQL_TRANSACTION_ISOLATION_OPTION}; + +$ReturnValues{SQL_TXN_ISOLATION_OPTION} = +{ + SQL_TXN_READ_UNCOMMITTED => 0x00000001 +, SQL_TXN_READ_COMMITTED => 0x00000002 +, SQL_TXN_REPEATABLE_READ => 0x00000004 +, SQL_TXN_SERIALIZABLE => 0x00000008 +}; +$ReturnValues{SQL_DEFAULT_TXN_ISOLATION} = $ReturnValues{SQL_TXN_ISOLATION_OPTION}; + +$ReturnValues{SQL_TXN_VERSIONING} = +{ + SQL_TXN_VERSIONING => 0x00000010 +}; +$ReturnValues{SQL_UNION} = +{ + SQL_U_UNION => 0x00000001 +, SQL_U_UNION_ALL => 0x00000002 +}; +$ReturnValues{SQL_UNION_STATEMENT} = +{ + SQL_US_UNION => 0x00000001 # SQL_U_UNION +, SQL_US_UNION_ALL => 0x00000002 # SQL_U_UNION_ALL +}; + +1; + +#line 1364 diff --git a/apps/lib/DBI/Const/GetInfoType.pm b/apps/lib/DBI/Const/GetInfoType.pm new file mode 100644 index 0000000..0c26516 --- /dev/null +++ b/apps/lib/DBI/Const/GetInfoType.pm @@ -0,0 +1,36 @@ +#line 1 "DBI/Const/GetInfoType.pm" +# $Id: GetInfoType.pm 8696 2007-01-24 23:12:38Z Tim $ +# +# Copyright (c) 2002 Tim Bunce Ireland +# +# Constant data describing info type codes for the DBI getinfo function. +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +package DBI::Const::GetInfoType; + +use strict; + +use Exporter (); + +use vars qw(@ISA @EXPORT @EXPORT_OK %GetInfoType); + +@ISA = qw(Exporter); +@EXPORT = qw(%GetInfoType); + +my +$VERSION = "2.008697"; + +#line 43 + +use DBI::Const::GetInfo::ANSI (); # liable to change +use DBI::Const::GetInfo::ODBC (); # liable to change + +%GetInfoType = +( + %DBI::Const::GetInfo::ANSI::InfoTypes # liable to change +, %DBI::Const::GetInfo::ODBC::InfoTypes # liable to change +); + +1; diff --git a/apps/lib/DBI/DBD/SqlEngine.pm b/apps/lib/DBI/DBD/SqlEngine.pm new file mode 100644 index 0000000..5637be9 --- /dev/null +++ b/apps/lib/DBI/DBD/SqlEngine.pm @@ -0,0 +1,1668 @@ +#line 1 "DBI/DBD/SqlEngine.pm" +# -*- perl -*- +# +# DBI::DBD::SqlEngine - A base class for implementing DBI drivers that +# have not an own SQL engine +# +# This module is currently maintained by +# +# H.Merijn Brand & Jens Rehsack +# +# The original author is Jochen Wiedmann. +# +# Copyright (C) 2009-2013 by H.Merijn Brand & Jens Rehsack +# Copyright (C) 2004 by Jeff Zucker +# Copyright (C) 1998 by Jochen Wiedmann +# +# All rights reserved. +# +# You may distribute this module under the terms of either the GNU +# General Public License or the Artistic License, as specified in +# the Perl README file. + +require 5.008; + +use strict; + +use DBI (); +require DBI::SQL::Nano; + +package DBI::DBD::SqlEngine; + +use strict; + +use Carp; +use vars qw( @ISA $VERSION $drh %methods_installed); + +$VERSION = "0.06"; + +$drh = undef; # holds driver handle(s) once initialized + +DBI->setup_driver("DBI::DBD::SqlEngine"); # only needed once but harmless to repeat + +my %accessors = ( + versions => "get_driver_versions", + new_meta => "new_sql_engine_meta", + get_meta => "get_sql_engine_meta", + set_meta => "set_sql_engine_meta", + clear_meta => "clear_sql_engine_meta", + ); + +sub driver ($;$) +{ + my ( $class, $attr ) = @_; + + # Drivers typically use a singleton object for the $drh + # We use a hash here to have one singleton per subclass. + # (Otherwise DBD::CSV and DBD::DBM, for example, would + # share the same driver object which would cause problems.) + # An alternative would be to not cache the $drh here at all + # and require that subclasses do that. Subclasses should do + # their own caching, so caching here just provides extra safety. + $drh->{$class} and return $drh->{$class}; + + $attr ||= {}; + { + no strict "refs"; + unless ( $attr->{Attribution} ) + { + $class eq "DBI::DBD::SqlEngine" + and $attr->{Attribution} = "$class by Jens Rehsack"; + $attr->{Attribution} ||= ${ $class . "::ATTRIBUTION" } + || "oops the author of $class forgot to define this"; + } + $attr->{Version} ||= ${ $class . "::VERSION" }; + $attr->{Name} or ( $attr->{Name} = $class ) =~ s/^DBD\:\://; + } + + $drh->{$class} = DBI::_new_drh( $class . "::dr", $attr ); + $drh->{$class}->STORE( ShowErrorStatement => 1 ); + + my $prefix = DBI->driver_prefix($class); + if ($prefix) + { + my $dbclass = $class . "::db"; + while ( my ( $accessor, $funcname ) = each %accessors ) + { + my $method = $prefix . $accessor; + $dbclass->can($method) and next; + my $inject = sprintf <<'EOI', $dbclass, $method, $dbclass, $funcname; +sub %s::%s +{ + my $func = %s->can (q{%s}); + goto &$func; + } +EOI + eval $inject; + $dbclass->install_method($method); + } + } + else + { + warn "Using DBI::DBD::SqlEngine with unregistered driver $class.\n" + . "Reading documentation how to prevent is strongly recommended.\n"; + + } + + # XXX inject DBD::XXX::Statement unless exists + + my $stclass = $class . "::st"; + $stclass->install_method("sql_get_colnames") unless ( $methods_installed{__PACKAGE__}++ ); + + return $drh->{$class}; +} # driver + +sub CLONE +{ + undef $drh; +} # CLONE + +# ====== DRIVER ================================================================ + +package DBI::DBD::SqlEngine::dr; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +use Carp qw/carp/; + +$imp_data_size = 0; + +sub connect ($$;$$$) +{ + my ( $drh, $dbname, $user, $auth, $attr ) = @_; + + # create a 'blank' dbh + my $dbh = DBI::_new_dbh( + $drh, + { + Name => $dbname, + USER => $user, + CURRENT_USER => $user, + } + ); + + if ($dbh) + { + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->func( 0, "init_default_attributes" ); + my $two_phased_init; + defined $dbh->{sql_init_phase} and $two_phased_init = ++$dbh->{sql_init_phase}; + my %second_phase_attrs; + my @func_inits; + + # this must be done to allow DBI.pm reblessing got handle after successful connecting + exists $attr->{RootClass} and $second_phase_attrs{RootClass} = delete $attr->{RootClass}; + + my ( $var, $val ); + while ( length $dbname ) + { + if ( $dbname =~ s/^((?:[^\\;]|\\.)*?);//s ) + { + $var = $1; + } + else + { + $var = $dbname; + $dbname = ""; + } + + if ( $var =~ m/^(.+?)=(.*)/s ) + { + $var = $1; + ( $val = $2 ) =~ s/\\(.)/$1/g; + exists $attr->{$var} + and carp("$var is given in DSN *and* \$attr during DBI->connect()") + if ($^W); + exists $attr->{$var} or $attr->{$var} = $val; + } + elsif ( $var =~ m/^(.+?)=>(.*)/s ) + { + $var = $1; + ( $val = $2 ) =~ s/\\(.)/$1/g; + my $ref = eval $val; + # $dbh->$var($ref); + push( @func_inits, $var, $ref ); + } + } + + # The attributes need to be sorted in a specific way as the + # assignment is through tied hashes and calls STORE on each + # attribute. Some attributes require to be called prior to + # others + # e.g. f_dir *must* be done before xx_tables in DBD::File + # The dbh attribute sql_init_order is a hash with the order + # as key (low is first, 0 .. 100) and the attributes that + # are set to that oreder as anon-list as value: + # { 0 => [qw( AutoCommit PrintError RaiseError Profile ... )], + # 10 => [ list of attr to be dealt with immediately after first ], + # 50 => [ all fields that are unspecified or default sort order ], + # 90 => [ all fields that are needed after other initialisation ], + # } + + my %order = map { + my $order = $_; + map { ( $_ => $order ) } @{ $dbh->{sql_init_order}{$order} }; + } sort { $a <=> $b } keys %{ $dbh->{sql_init_order} || {} }; + my @ordered_attr = + map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, defined $order{$_} ? $order{$_} : 50 ] } + keys %$attr; + + # initialize given attributes ... lower weighted before higher weighted + foreach my $a (@ordered_attr) + { + exists $attr->{$a} or next; + $two_phased_init and eval { + $dbh->{$a} = $attr->{$a}; + delete $attr->{$a}; + }; + $@ and $second_phase_attrs{$a} = delete $attr->{$a}; + $two_phased_init or $dbh->STORE( $a, delete $attr->{$a} ); + } + + $two_phased_init and $dbh->func( 1, "init_default_attributes" ); + %$attr = %second_phase_attrs; + + for ( my $i = 0; $i < scalar(@func_inits); $i += 2 ) + { + my $func = $func_inits[$i]; + my $arg = $func_inits[ $i + 1 ]; + $dbh->$func($arg); + } + + $dbh->func("init_done"); + + $dbh->STORE( Active => 1 ); + } + + return $dbh; +} # connect + +sub data_sources ($;$) +{ + my ( $drh, $attr ) = @_; + + my $tbl_src; + $attr + and defined $attr->{sql_table_source} + and $attr->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource') + and $tbl_src = $attr->{sql_table_source}; + + !defined($tbl_src) + and $drh->{ImplementorClass}->can('default_table_source') + and $tbl_src = $drh->{ImplementorClass}->default_table_source(); + defined($tbl_src) or return; + + $tbl_src->data_sources( $drh, $attr ); +} # data_sources + +sub disconnect_all +{ +} # disconnect_all + +sub DESTROY +{ + undef; +} # DESTROY + +# ====== DATABASE ============================================================== + +package DBI::DBD::SqlEngine::db; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +use Carp; + +if ( eval { require Clone; } ) +{ + Clone->import("clone"); +} +else +{ + require Storable; # in CORE since 5.7.3 + *clone = \&Storable::dclone; +} + +$imp_data_size = 0; + +sub ping +{ + ( $_[0]->FETCH("Active") ) ? 1 : 0; +} # ping + +sub data_sources +{ + my ( $dbh, $attr, @other ) = @_; + my $drh = $dbh->{Driver}; # XXX proxy issues? + ref($attr) eq 'HASH' or $attr = {}; + defined( $attr->{sql_table_source} ) or $attr->{sql_table_source} = $dbh->{sql_table_source}; + return $drh->data_sources( $attr, @other ); +} + +sub prepare ($$;@) +{ + my ( $dbh, $statement, @attribs ) = @_; + + # create a 'blank' sth + my $sth = DBI::_new_sth( $dbh, { Statement => $statement } ); + + if ($sth) + { + my $class = $sth->FETCH("ImplementorClass"); + $class =~ s/::st$/::Statement/; + my $stmt; + + # if using SQL::Statement version > 1 + # cache the parser object if the DBD supports parser caching + # SQL::Nano and older SQL::Statements don't support this + + if ( $class->isa("SQL::Statement") ) + { + my $parser = $dbh->{sql_parser_object}; + $parser ||= eval { $dbh->func("sql_parser_object") }; + if ($@) + { + $stmt = eval { $class->new($statement) }; + } + else + { + $stmt = eval { $class->new( $statement, $parser ) }; + } + } + else + { + $stmt = eval { $class->new($statement) }; + } + if ( $@ || $stmt->{errstr} ) + { + $dbh->set_err( $DBI::stderr, $@ || $stmt->{errstr} ); + undef $sth; + } + else + { + $sth->STORE( "sql_stmt", $stmt ); + $sth->STORE( "sql_params", [] ); + $sth->STORE( "NUM_OF_PARAMS", scalar( $stmt->params() ) ); + my @colnames = $sth->sql_get_colnames(); + $sth->STORE( "NUM_OF_FIELDS", scalar @colnames ); + } + } + return $sth; +} # prepare + +sub set_versions +{ + my $dbh = $_[0]; + $dbh->{sql_engine_version} = $DBI::DBD::SqlEngine::VERSION; + for (qw( nano_version statement_version )) + { + defined $DBI::SQL::Nano::versions->{$_} or next; + $dbh->{"sql_$_"} = $DBI::SQL::Nano::versions->{$_}; + } + $dbh->{sql_handler} = + $dbh->{sql_statement_version} + ? "SQL::Statement" + : "DBI::SQL::Nano"; + + return $dbh; +} # set_versions + +sub init_valid_attributes +{ + my $dbh = $_[0]; + + $dbh->{sql_valid_attrs} = { + sql_engine_version => 1, # DBI::DBD::SqlEngine version + sql_handler => 1, # Nano or S:S + sql_nano_version => 1, # Nano version + sql_statement_version => 1, # S:S version + sql_flags => 1, # flags for SQL::Parser + sql_dialect => 1, # dialect for SQL::Parser + sql_quoted_identifier_case => 1, # case for quoted identifiers + sql_identifier_case => 1, # case for non-quoted identifiers + sql_parser_object => 1, # SQL::Parser instance + sql_sponge_driver => 1, # Sponge driver for table_info () + sql_valid_attrs => 1, # SQL valid attributes + sql_readonly_attrs => 1, # SQL readonly attributes + sql_init_phase => 1, # Only during initialization + sql_meta => 1, # meta data for tables + sql_meta_map => 1, # mapping table for identifier case + sql_data_source => 1, # reasonable datasource class + }; + $dbh->{sql_readonly_attrs} = { + sql_engine_version => 1, # DBI::DBD::SqlEngine version + sql_handler => 1, # Nano or S:S + sql_nano_version => 1, # Nano version + sql_statement_version => 1, # S:S version + sql_quoted_identifier_case => 1, # case for quoted identifiers + sql_parser_object => 1, # SQL::Parser instance + sql_sponge_driver => 1, # Sponge driver for table_info () + sql_valid_attrs => 1, # SQL valid attributes + sql_readonly_attrs => 1, # SQL readonly attributes + }; + + return $dbh; +} # init_valid_attributes + +sub init_default_attributes +{ + my ( $dbh, $phase ) = @_; + my $given_phase = $phase; + + unless ( defined($phase) ) + { + # we have an "old" driver here + $phase = defined $dbh->{sql_init_phase}; + $phase and $phase = $dbh->{sql_init_phase}; + } + + if ( 0 == $phase ) + { + # must be done first, because setting flags implicitly calls $dbdname::db->STORE + $dbh->func("init_valid_attributes"); + + $dbh->func("set_versions"); + + $dbh->{sql_identifier_case} = 2; # SQL_IC_LOWER + $dbh->{sql_quoted_identifier_case} = 3; # SQL_IC_SENSITIVE + + $dbh->{sql_dialect} = "CSV"; + + $dbh->{sql_init_phase} = $given_phase; + + # complete derived attributes, if required + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix($drv_class); + my $valid_attrs = $drv_prefix . "valid_attrs"; + my $ro_attrs = $drv_prefix . "readonly_attrs"; + + # check whether we're running in a Gofer server or not (see + # validate_FETCH_attr for details) + $dbh->{sql_engine_in_gofer} = + ( defined $INC{"DBD/Gofer.pm"} && ( caller(5) )[0] eq "DBI::Gofer::Execute" ); + $dbh->{sql_meta} = {}; + $dbh->{sql_meta_map} = {}; # choose new name because it contains other keys + + # init_default_attributes calls inherited routine before derived DBD's + # init their default attributes, so we don't override something here + # + # defining an order of attribute initialization from connect time + # specified ones with a magic baarier (see next statement) + my $drv_pfx_meta = $drv_prefix . "meta"; + $dbh->{sql_init_order} = { + 0 => [qw( Profile RaiseError PrintError AutoCommit )], + 90 => [ "sql_meta", $dbh->{$drv_pfx_meta} ? $dbh->{$drv_pfx_meta} : () ], + }; + # ensuring Profile, RaiseError, PrintError, AutoCommit are initialized + # first when initializing attributes from connect time specified + # attributes + # further, initializations to predefined tables are happens after any + # unspecified attribute initialization (that default to order 50) + + my @comp_attrs = qw(valid_attrs version readonly_attrs); + + if ( exists $dbh->{$drv_pfx_meta} and !$dbh->{sql_engine_in_gofer} ) + { + my $attr = $dbh->{$drv_pfx_meta}; + defined $attr + and defined $dbh->{$valid_attrs} + and !defined $dbh->{$valid_attrs}{$attr} + and $dbh->{$valid_attrs}{$attr} = 1; + + my %h; + tie %h, "DBI::DBD::SqlEngine::TieTables", $dbh; + $dbh->{$attr} = \%h; + + push @comp_attrs, "meta"; + } + + foreach my $comp_attr (@comp_attrs) + { + my $attr = $drv_prefix . $comp_attr; + defined $dbh->{$valid_attrs} + and !defined $dbh->{$valid_attrs}{$attr} + and $dbh->{$valid_attrs}{$attr} = 1; + defined $dbh->{$ro_attrs} + and !defined $dbh->{$ro_attrs}{$attr} + and $dbh->{$ro_attrs}{$attr} = 1; + } + } + + return $dbh; +} # init_default_attributes + +sub init_done +{ + defined $_[0]->{sql_init_phase} and delete $_[0]->{sql_init_phase}; + delete $_[0]->{sql_valid_attrs}->{sql_init_phase}; + return; +} + +sub sql_parser_object +{ + my $dbh = $_[0]; + my $dialect = $dbh->{sql_dialect} || "CSV"; + my $parser = { + RaiseError => $dbh->FETCH("RaiseError"), + PrintError => $dbh->FETCH("PrintError"), + }; + my $sql_flags = $dbh->FETCH("sql_flags") || {}; + %$parser = ( %$parser, %$sql_flags ); + $parser = SQL::Parser->new( $dialect, $parser ); + $dbh->{sql_parser_object} = $parser; + return $parser; +} # sql_parser_object + +sub sql_sponge_driver +{ + my $dbh = $_[0]; + my $dbh2 = $dbh->{sql_sponge_driver}; + unless ($dbh2) + { + $dbh2 = $dbh->{sql_sponge_driver} = DBI->connect("DBI:Sponge:"); + unless ($dbh2) + { + $dbh->set_err( $DBI::stderr, $DBI::errstr ); + return; + } + } +} + +sub disconnect ($) +{ + %{ $_[0]->{sql_meta} } = (); + %{ $_[0]->{sql_meta_map} } = (); + $_[0]->STORE( Active => 0 ); + return 1; +} # disconnect + +sub validate_FETCH_attr +{ + my ( $dbh, $attrib ) = @_; + + # If running in a Gofer server, access to our tied compatibility hash + # would force Gofer to serialize the tieing object including it's + # private $dbh reference used to do the driver function calls. + # This will result in nasty exceptions. So return a copy of the + # sql_meta structure instead, which is the source of for the compatibility + # tie-hash. It's not as good as liked, but the best we can do in this + # situation. + if ( $dbh->{sql_engine_in_gofer} ) + { + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix($drv_class); + exists $dbh->{ $drv_prefix . "meta" } && $attrib eq $dbh->{ $drv_prefix . "meta" } + and $attrib = "sql_meta"; + } + + return $attrib; +} + +sub FETCH ($$) +{ + my ( $dbh, $attrib ) = @_; + $attrib eq "AutoCommit" + and return 1; + + # Driver private attributes are lower cased + if ( $attrib eq ( lc $attrib ) ) + { + # first let the implementation deliver an alias for the attribute to fetch + # after it validates the legitimation of the fetch request + $attrib = $dbh->func( $attrib, "validate_FETCH_attr" ) or return; + + my $attr_prefix; + $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1; + unless ($attr_prefix) + { + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + $attr_prefix = DBI->driver_prefix($drv_class); + $attrib = $attr_prefix . $attrib; + } + my $valid_attrs = $attr_prefix . "valid_attrs"; + my $ro_attrs = $attr_prefix . "readonly_attrs"; + + exists $dbh->{$valid_attrs} + and ( $dbh->{$valid_attrs}{$attrib} + or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) ); + exists $dbh->{$ro_attrs} + and $dbh->{$ro_attrs}{$attrib} + and defined $dbh->{$attrib} + and refaddr( $dbh->{$attrib} ) + and return clone( $dbh->{$attrib} ); + + return $dbh->{$attrib}; + } + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); +} # FETCH + +sub validate_STORE_attr +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "sql_identifier_case" || $attrib eq "sql_quoted_identifier_case" + and $value < 1 || $value > 4 ) + { + croak "attribute '$attrib' must have a value from 1 .. 4 (SQL_IC_UPPER .. SQL_IC_MIXED)"; + # XXX correctly a remap of all entries in sql_meta/sql_meta_map is required here + } + + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix($drv_class); + + exists $dbh->{ $drv_prefix . "meta" } + and $attrib eq $dbh->{ $drv_prefix . "meta" } + and $attrib = "sql_meta"; + + return ( $attrib, $value ); +} + +# the ::db::STORE method is what gets called when you set +# a lower-cased database handle attribute such as $dbh->{somekey}=$someval; +# +# STORE should check to make sure that "somekey" is a valid attribute name +# but only if it is really one of our attributes (starts with dbm_ or foo_) +# You can also check for valid values for the attributes if needed +# and/or perform other operations +# +sub STORE ($$$) +{ + my ( $dbh, $attrib, $value ) = @_; + + if ( $attrib eq "AutoCommit" ) + { + $value and return 1; # is already set + croak "Can't disable AutoCommit"; + } + + if ( $attrib eq lc $attrib ) + { + # Driver private attributes are lower cased + + ( $attrib, $value ) = $dbh->func( $attrib, $value, "validate_STORE_attr" ); + $attrib or return; + + my $attr_prefix; + $attrib =~ m/^([a-z]+_)/ and $attr_prefix = $1; + unless ($attr_prefix) + { + ( my $drv_class = $dbh->{ImplementorClass} ) =~ s/::db$//; + $attr_prefix = DBI->driver_prefix($drv_class); + $attrib = $attr_prefix . $attrib; + } + my $valid_attrs = $attr_prefix . "valid_attrs"; + my $ro_attrs = $attr_prefix . "readonly_attrs"; + + exists $dbh->{$valid_attrs} + and ( $dbh->{$valid_attrs}{$attrib} + or return $dbh->set_err( $DBI::stderr, "Invalid attribute '$attrib'" ) ); + exists $dbh->{$ro_attrs} + and $dbh->{$ro_attrs}{$attrib} + and defined $dbh->{$attrib} + and return $dbh->set_err( $DBI::stderr, + "attribute '$attrib' is readonly and must not be modified" ); + + if ( $attrib eq "sql_meta" ) + { + while ( my ( $k, $v ) = each %$value ) + { + $dbh->{$attrib}{$k} = $v; + } + } + else + { + $dbh->{$attrib} = $value; + } + + return 1; + } + + return $dbh->SUPER::STORE( $attrib, $value ); +} # STORE + +sub get_driver_versions +{ + my ( $dbh, $table ) = @_; + my %vsn = ( + OS => "$^O ($Config::Config{osvers})", + Perl => "$] ($Config::Config{archname})", + DBI => $DBI::VERSION, + ); + my %vmp; + + my $sql_engine_verinfo = + join " ", + $dbh->{sql_engine_version}, "using", $dbh->{sql_handler}, + $dbh->{sql_handler} eq "SQL::Statement" + ? $dbh->{sql_statement_version} + : $dbh->{sql_nano_version}; + + my $indent = 0; + my @deriveds = ( $dbh->{ImplementorClass} ); + while (@deriveds) + { + my $derived = shift @deriveds; + $derived eq "DBI::DBD::SqlEngine::db" and last; + $derived->isa("DBI::DBD::SqlEngine::db") or next; + #no strict 'refs'; + eval "push \@deriveds, \@${derived}::ISA"; + #use strict; + ( my $drv_class = $derived ) =~ s/::db$//; + my $drv_prefix = DBI->driver_prefix($drv_class); + my $ddgv = $dbh->{ImplementorClass}->can("get_${drv_prefix}versions"); + my $drv_version = $ddgv ? &$ddgv( $dbh, $table ) : $dbh->{ $drv_prefix . "version" }; + $drv_version ||= + eval { $derived->VERSION() }; # XXX access $drv_class::VERSION via symbol table + $vsn{$drv_class} = $drv_version; + $indent and $vmp{$drv_class} = " " x $indent . $drv_class; + $indent += 2; + } + + $vsn{"DBI::DBD::SqlEngine"} = $sql_engine_verinfo; + $indent and $vmp{"DBI::DBD::SqlEngine"} = " " x $indent . "DBI::DBD::SqlEngine"; + + $DBI::PurePerl and $vsn{"DBI::PurePerl"} = $DBI::PurePerl::VERSION; + + $indent += 20; + my @versions = map { sprintf "%-${indent}s %s", $vmp{$_} || $_, $vsn{$_} } + sort { + $a->isa($b) and return -1; + $b->isa($a) and return 1; + $a->isa("DBI::DBD::SqlEngine") and return -1; + $b->isa("DBI::DBD::SqlEngine") and return 1; + return $a cmp $b; + } keys %vsn; + + return wantarray ? @versions : join "\n", @versions; +} # get_versions + +sub get_single_table_meta +{ + my ( $dbh, $table, $attr ) = @_; + my $meta; + + $table eq "." + and return $dbh->FETCH($attr); + + ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; + ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); + $meta or croak "No such table '$table'"; + + # prevent creation of undef attributes + return $class->get_table_meta_attr( $meta, $attr ); +} # get_single_table_meta + +sub get_sql_engine_meta +{ + my ( $dbh, $table, $attr ) = @_; + + my $gstm = $dbh->{ImplementorClass}->can("get_single_table_meta"); + + $table eq "*" + and $table = [ ".", keys %{ $dbh->{sql_meta} } ]; + $table eq "+" + and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ]; + ref $table eq "Regexp" + and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_meta} } ]; + + ref $table || ref $attr + or return $gstm->( $dbh, $table, $attr ); + + ref $table or $table = [$table]; + ref $attr or $attr = [$attr]; + "ARRAY" eq ref $table + or return + $dbh->set_err( $DBI::stderr, + "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " . ref $table ); + "ARRAY" eq ref $attr + or return $dbh->set_err( + "Invalid argument for \$attr - SCALAR or ARRAY expected but got " . ref $attr ); + + my %results; + foreach my $tname ( @{$table} ) + { + my %tattrs; + foreach my $aname ( @{$attr} ) + { + $tattrs{$aname} = $gstm->( $dbh, $tname, $aname ); + } + $results{$tname} = \%tattrs; + } + + return \%results; +} # get_sql_engine_meta + +sub new_sql_engine_meta +{ + my ( $dbh, $table, $values ) = @_; + my $respect_case = 0; + + "HASH" eq ref $values + or croak "Invalid argument for \$values - SCALAR or HASH expected but got " . ref $values; + + $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers + $table =~ s/\"$//; + + unless ($respect_case) + { + defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table}; + } + + $dbh->{sql_meta}{$table} = { %{$values} }; + my $class; + defined $values->{sql_table_class} and $class = $values->{sql_table_class}; + defined $class or ( $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; + # XXX we should never hit DBD::File::Table::get_table_meta here ... + my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, $respect_case ); + 1; +} # new_sql_engine_meta + +sub set_single_table_meta +{ + my ( $dbh, $table, $attr, $value ) = @_; + my $meta; + + $table eq "." + and return $dbh->STORE( $attr, $value ); + + ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; + ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); # 1 means: respect case + $meta or croak "No such table '$table'"; + $class->set_table_meta_attr( $meta, $attr, $value ); + + return $dbh; +} # set_single_table_meta + +sub set_sql_engine_meta +{ + my ( $dbh, $table, $attr, $value ) = @_; + + my $sstm = $dbh->{ImplementorClass}->can("set_single_table_meta"); + + $table eq "*" + and $table = [ ".", keys %{ $dbh->{sql_meta} } ]; + $table eq "+" + and $table = [ grep { m/^[_A-Za-z0-9]+$/ } keys %{ $dbh->{sql_meta} } ]; + ref($table) eq "Regexp" + and $table = [ grep { $_ =~ $table } keys %{ $dbh->{sql_meta} } ]; + + ref $table || ref $attr + or return $sstm->( $dbh, $table, $attr, $value ); + + ref $table or $table = [$table]; + ref $attr or $attr = { $attr => $value }; + "ARRAY" eq ref $table + or croak "Invalid argument for \$table - SCALAR, Regexp or ARRAY expected but got " + . ref $table; + "HASH" eq ref $attr + or croak "Invalid argument for \$attr - SCALAR or HASH expected but got " . ref $attr; + + foreach my $tname ( @{$table} ) + { + while ( my ( $aname, $aval ) = each %$attr ) + { + $sstm->( $dbh, $tname, $aname, $aval ); + } + } + + return $dbh; +} # set_file_meta + +sub clear_sql_engine_meta +{ + my ( $dbh, $table ) = @_; + + ( my $class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; + my ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 ); + $meta and %{$meta} = (); + + return; +} # clear_file_meta + +sub DESTROY ($) +{ + my $dbh = shift; + $dbh->SUPER::FETCH("Active") and $dbh->disconnect; + undef $dbh->{sql_parser_object}; +} # DESTROY + +sub type_info_all ($) +{ + [ + { + TYPE_NAME => 0, + DATA_TYPE => 1, + PRECISION => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE => 9, + MONEY => 10, + AUTO_INCREMENT => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ + "VARCHAR", DBI::SQL_VARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, + ], + [ "CHAR", DBI::SQL_CHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, 999999, ], + [ "INTEGER", DBI::SQL_INTEGER(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ], + [ "REAL", DBI::SQL_REAL(), undef, "", "", undef, 0, 0, 1, 0, 0, 0, undef, 0, 0, ], + [ + "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, + 999999, + ], + [ + "BLOB", DBI::SQL_LONGVARBINARY(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, + 999999, + ], + [ + "TEXT", DBI::SQL_LONGVARCHAR(), undef, "'", "'", undef, 0, 1, 1, 0, 0, 0, undef, 1, + 999999, + ], + ]; +} # type_info_all + +sub get_avail_tables +{ + my $dbh = $_[0]; + my @tables = (); + + if ( $dbh->{sql_handler} eq "SQL::Statement" and $dbh->{sql_ram_tables} ) + { + # XXX map +[ undef, undef, $_, "TABLE", "TEMP" ], keys %{...} + foreach my $table ( keys %{ $dbh->{sql_ram_tables} } ) + { + push @tables, [ undef, undef, $table, "TABLE", "TEMP" ]; + } + } + + my $tbl_src; + defined $dbh->{sql_table_source} + and $dbh->{sql_table_source}->isa('DBI::DBD::SqlEngine::TableSource') + and $tbl_src = $dbh->{sql_table_source}; + + !defined($tbl_src) + and $dbh->{Driver}->{ImplementorClass}->can('default_table_source') + and $tbl_src = $dbh->{Driver}->{ImplementorClass}->default_table_source(); + defined($tbl_src) and push( @tables, $tbl_src->avail_tables($dbh) ); + + return @tables; +} # get_avail_tables + +{ + my $names = [qw( TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS )]; + + sub table_info ($) + { + my $dbh = shift; + + my @tables = $dbh->func("get_avail_tables"); + + # Temporary kludge: DBD::Sponge dies if @tables is empty. :-( + # this no longer seems to be true @tables or return; + + my $dbh2 = $dbh->func("sql_sponge_driver"); + my $sth = $dbh2->prepare( + "TABLE_INFO", + { + rows => \@tables, + NAME => $names, + } + ); + $sth or return $dbh->set_err( $DBI::stderr, $dbh2->errstr ); + $sth->execute or return; + return $sth; + } # table_info +} + +sub list_tables ($) +{ + my $dbh = shift; + my @table_list; + + my @tables = $dbh->func("get_avail_tables") or return; + foreach my $ref (@tables) + { + # rt69260 and rt67223 - the same issue in 2 different queues + push @table_list, $ref->[2]; + } + + return @table_list; +} # list_tables + +sub quote ($$;$) +{ + my ( $self, $str, $type ) = @_; + defined $str or return "NULL"; + defined $type && ( $type == DBI::SQL_NUMERIC() + || $type == DBI::SQL_DECIMAL() + || $type == DBI::SQL_INTEGER() + || $type == DBI::SQL_SMALLINT() + || $type == DBI::SQL_FLOAT() + || $type == DBI::SQL_REAL() + || $type == DBI::SQL_DOUBLE() + || $type == DBI::SQL_TINYINT() ) + and return $str; + + $str =~ s/\\/\\\\/sg; + $str =~ s/\0/\\0/sg; + $str =~ s/\'/\\\'/sg; + $str =~ s/\n/\\n/sg; + $str =~ s/\r/\\r/sg; + return "'$str'"; +} # quote + +sub commit ($) +{ + my $dbh = shift; + $dbh->FETCH("Warn") + and carp "Commit ineffective while AutoCommit is on", -1; + return 1; +} # commit + +sub rollback ($) +{ + my $dbh = shift; + $dbh->FETCH("Warn") + and carp "Rollback ineffective while AutoCommit is on", -1; + return 0; +} # rollback + +# ====== Tie-Meta ============================================================== + +package DBI::DBD::SqlEngine::TieMeta; + +use Carp qw(croak); +require Tie::Hash; +@DBI::DBD::SqlEngine::TieMeta::ISA = qw(Tie::Hash); + +sub TIEHASH +{ + my ( $class, $tblClass, $tblMeta ) = @_; + + my $self = bless( + { + tblClass => $tblClass, + tblMeta => $tblMeta, + }, + $class + ); + return $self; +} # new + +sub STORE +{ + my ( $self, $meta_attr, $meta_val ) = @_; + + $self->{tblClass}->set_table_meta_attr( $self->{tblMeta}, $meta_attr, $meta_val ); + + return; +} # STORE + +sub FETCH +{ + my ( $self, $meta_attr ) = @_; + + return $self->{tblClass}->get_table_meta_attr( $self->{tblMeta}, $meta_attr ); +} # FETCH + +sub FIRSTKEY +{ + my $a = scalar keys %{ $_[0]->{tblMeta} }; + each %{ $_[0]->{tblMeta} }; +} # FIRSTKEY + +sub NEXTKEY +{ + each %{ $_[0]->{tblMeta} }; +} # NEXTKEY + +sub EXISTS +{ + exists $_[0]->{tblMeta}{ $_[1] }; +} # EXISTS + +sub DELETE +{ + croak "Can't delete single attributes from table meta structure"; +} # DELETE + +sub CLEAR +{ + %{ $_[0]->{tblMeta} } = (); +} # CLEAR + +sub SCALAR +{ + scalar %{ $_[0]->{tblMeta} }; +} # SCALAR + +# ====== Tie-Tables ============================================================ + +package DBI::DBD::SqlEngine::TieTables; + +use Carp qw(croak); +require Tie::Hash; +@DBI::DBD::SqlEngine::TieTables::ISA = qw(Tie::Hash); + +sub TIEHASH +{ + my ( $class, $dbh ) = @_; + + ( my $tbl_class = $dbh->{ImplementorClass} ) =~ s/::db$/::Table/; + my $self = bless( + { + dbh => $dbh, + tblClass => $tbl_class, + }, + $class + ); + return $self; +} # new + +sub STORE +{ + my ( $self, $table, $tbl_meta ) = @_; + + "HASH" eq ref $tbl_meta + or croak "Invalid data for storing as table meta data (must be hash)"; + + ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 ); + $meta or croak "Invalid table name '$table'"; + + while ( my ( $meta_attr, $meta_val ) = each %$tbl_meta ) + { + $self->{tblClass}->set_table_meta_attr( $meta, $meta_attr, $meta_val ); + } + + return; +} # STORE + +sub FETCH +{ + my ( $self, $table ) = @_; + + ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 ); + $meta or croak "Invalid table name '$table'"; + + my %h; + tie %h, "DBI::DBD::SqlEngine::TieMeta", $self->{tblClass}, $meta; + + return \%h; +} # FETCH + +sub FIRSTKEY +{ + my $a = scalar keys %{ $_[0]->{dbh}->{sql_meta} }; + each %{ $_[0]->{dbh}->{sql_meta} }; +} # FIRSTKEY + +sub NEXTKEY +{ + each %{ $_[0]->{dbh}->{sql_meta} }; +} # NEXTKEY + +sub EXISTS +{ + exists $_[0]->{dbh}->{sql_meta}->{ $_[1] } + or exists $_[0]->{dbh}->{sql_meta_map}->{ $_[1] }; +} # EXISTS + +sub DELETE +{ + my ( $self, $table ) = @_; + + ( undef, my $meta ) = $self->{tblClass}->get_table_meta( $self->{dbh}, $table, 1 ); + $meta or croak "Invalid table name '$table'"; + + delete $_[0]->{dbh}->{sql_meta}->{ $meta->{table_name} }; +} # DELETE + +sub CLEAR +{ + %{ $_[0]->{dbh}->{sql_meta} } = (); + %{ $_[0]->{dbh}->{sql_meta_map} } = (); +} # CLEAR + +sub SCALAR +{ + scalar %{ $_[0]->{dbh}->{sql_meta} }; +} # SCALAR + +# ====== STATEMENT ============================================================= + +package DBI::DBD::SqlEngine::st; + +use strict; +use warnings; + +use vars qw(@ISA $imp_data_size); + +$imp_data_size = 0; + +sub bind_param ($$$;$) +{ + my ( $sth, $pNum, $val, $attr ) = @_; + if ( $attr && defined $val ) + { + my $type = ref $attr eq "HASH" ? $attr->{TYPE} : $attr; + if ( $type == DBI::SQL_BIGINT() + || $type == DBI::SQL_INTEGER() + || $type == DBI::SQL_SMALLINT() + || $type == DBI::SQL_TINYINT() ) + { + $val += 0; + } + elsif ( $type == DBI::SQL_DECIMAL() + || $type == DBI::SQL_DOUBLE() + || $type == DBI::SQL_FLOAT() + || $type == DBI::SQL_NUMERIC() + || $type == DBI::SQL_REAL() ) + { + $val += 0.; + } + else + { + $val = "$val"; + } + } + $sth->{sql_params}[ $pNum - 1 ] = $val; + return 1; +} # bind_param + +sub execute +{ + my $sth = shift; + my $params = @_ ? ( $sth->{sql_params} = [@_] ) : $sth->{sql_params}; + + $sth->finish; + my $stmt = $sth->{sql_stmt}; + + # must not proved when already executed - SQL::Statement modifies + # received params + unless ( $sth->{sql_params_checked}++ ) + { + # SQL::Statement and DBI::SQL::Nano will return the list of required params + # when called in list context. Do not look into the several items, they're + # implementation specific and may change without warning + unless ( ( my $req_prm = $stmt->params() ) == ( my $nparm = @$params ) ) + { + my $msg = "You passed $nparm parameters where $req_prm required"; + return $sth->set_err( $DBI::stderr, $msg ); + } + } + + my @err; + my $result; + eval { + local $SIG{__WARN__} = sub { push @err, @_ }; + $result = $stmt->execute( $sth, $params ); + }; + unless ( defined $result ) + { + $sth->set_err( $DBI::stderr, $@ || $stmt->{errstr} || $err[0] ); + return; + } + + if ( $stmt->{NUM_OF_FIELDS} ) + { # is a SELECT statement + $sth->STORE( Active => 1 ); + $sth->FETCH("NUM_OF_FIELDS") + or $sth->STORE( "NUM_OF_FIELDS", $stmt->{NUM_OF_FIELDS} ); + } + return $result; +} # execute + +sub finish +{ + my $sth = $_[0]; + $sth->SUPER::STORE( Active => 0 ); + delete $sth->{sql_stmt}{data}; + return 1; +} # finish + +sub fetch ($) +{ + my $sth = $_[0]; + my $data = $sth->{sql_stmt}{data}; + if ( !$data || ref $data ne "ARRAY" ) + { + $sth->set_err( + $DBI::stderr, + "Attempt to fetch row without a preceding execute () call or from a non-SELECT statement" + ); + return; + } + my $dav = shift @$data; + unless ($dav) + { + $sth->finish; + return; + } + if ( $sth->FETCH("ChopBlanks") ) # XXX: (TODO) Only chop on CHAR fields, + { # not on VARCHAR or NUMERIC (see DBI docs) + $_ && $_ =~ s/ +$// for @$dav; + } + return $sth->_set_fbav($dav); +} # fetch + +no warnings 'once'; +*fetchrow_arrayref = \&fetch; + +use warnings; + +sub sql_get_colnames +{ + my $sth = $_[0]; + # Being a bit dirty here, as neither SQL::Statement::Structure nor + # DBI::SQL::Nano::Statement_ does not offer an interface to the + # required data + my @colnames; + if ( $sth->{sql_stmt}->{NAME} and "ARRAY" eq ref( $sth->{sql_stmt}->{NAME} ) ) + { + @colnames = @{ $sth->{sql_stmt}->{NAME} }; + } + elsif ( $sth->{sql_stmt}->isa('SQL::Statement') ) + { + my $stmt = $sth->{sql_stmt} || {}; + my @coldefs = @{ $stmt->{column_defs} || [] }; + @colnames = map { $_->{name} || $_->{value} } @coldefs; + } + @colnames = $sth->{sql_stmt}->column_names() unless (@colnames); + + @colnames = () if ( grep { m/\*/ } @colnames ); + + return @colnames; +} + +sub FETCH ($$) +{ + my ( $sth, $attrib ) = @_; + + $attrib eq "NAME" and return [ $sth->sql_get_colnames() ]; + + $attrib eq "TYPE" and return [ ( DBI::SQL_VARCHAR() ) x scalar $sth->sql_get_colnames() ]; + $attrib eq "TYPE_NAME" and return [ ("VARCHAR") x scalar $sth->sql_get_colnames() ]; + $attrib eq "PRECISION" and return [ (0) x scalar $sth->sql_get_colnames() ]; + $attrib eq "NULLABLE" and return [ (1) x scalar $sth->sql_get_colnames() ]; + + if ( $attrib eq lc $attrib ) + { + # Private driver attributes are lower cased + return $sth->{$attrib}; + } + + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); +} # FETCH + +sub STORE ($$$) +{ + my ( $sth, $attrib, $value ) = @_; + if ( $attrib eq lc $attrib ) # Private driver attributes are lower cased + { + $sth->{$attrib} = $value; + return 1; + } + return $sth->SUPER::STORE( $attrib, $value ); +} # STORE + +sub DESTROY ($) +{ + my $sth = shift; + $sth->SUPER::FETCH("Active") and $sth->finish; + undef $sth->{sql_stmt}; + undef $sth->{sql_params}; +} # DESTROY + +sub rows ($) +{ + return $_[0]->{sql_stmt}{NUM_OF_ROWS}; +} # rows + +# ====== TableSource =========================================================== + +package DBI::DBD::SqlEngine::TableSource; + +use strict; +use warnings; + +use Carp; + +sub data_sources ($;$) +{ + my ( $class, $drh, $attrs ) = @_; + croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement data_sources" ); +} + +sub avail_tables +{ + my ( $self, $dbh ) = @_; + croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement avail_tables" ); +} + +# ====== DataSource ============================================================ + +package DBI::DBD::SqlEngine::DataSource; + +use strict; +use warnings; + +use Carp; + +sub complete_table_name ($$;$) +{ + my ( $self, $meta, $table, $respect_case ) = @_; + croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement complete_table_name" ); +} + +sub open_data ($) +{ + my ( $self, $meta, $attrs, $flags ) = @_; + croak( ( ref( $_[0] ) ? ref( $_[0] ) : $_[0] ) . " must implement open_data" ); +} + +# ====== SQL::STATEMENT ======================================================== + +package DBI::DBD::SqlEngine::Statement; + +use strict; +use warnings; + +use Carp; + +@DBI::DBD::SqlEngine::Statement::ISA = qw(DBI::SQL::Nano::Statement); + +sub open_table ($$$$$) +{ + my ( $self, $data, $table, $createMode, $lockMode ) = @_; + + my $class = ref $self; + $class =~ s/::Statement/::Table/; + + my $flags = { + createMode => $createMode, + lockMode => $lockMode, + }; + $self->{command} eq "DROP" and $flags->{dropMode} = 1; + + my ( $tblnm, $table_meta ) = $class->get_table_meta( $data->{Database}, $table, 1 ) + or croak "Cannot find appropriate meta for table '$table'"; + + defined $table_meta->{sql_table_class} and $class = $table_meta->{sql_table_class}; + + # because column name mapping is initialized in constructor ... + # and therefore specific opening operations might be done before + # reaching DBI::DBD::SqlEngine::Table->new(), we need to intercept + # ReadOnly here + my $write_op = $createMode || $lockMode || $flags->{dropMode}; + if ($write_op) + { + $table_meta->{readonly} + and croak "Table '$table' is marked readonly - " + . $self->{command} + . ( $lockMode ? " with locking" : "" ) + . " command forbidden"; + } + + return $class->new( $data, { table => $table }, $flags ); +} # open_table + +# ====== SQL::TABLE ============================================================ + +package DBI::DBD::SqlEngine::Table; + +use strict; +use warnings; + +use Carp; + +@DBI::DBD::SqlEngine::Table::ISA = qw(DBI::SQL::Nano::Table); + +sub bootstrap_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_; + + defined $dbh->{ReadOnly} + and !defined( $meta->{readonly} ) + and $meta->{readonly} = $dbh->{ReadOnly}; + defined $meta->{sql_identifier_case} + or $meta->{sql_identifier_case} = $dbh->{sql_identifier_case}; + + exists $meta->{sql_data_source} or $meta->{sql_data_source} = $dbh->{sql_data_source}; + + $meta; +} + +sub init_table_meta +{ + my ( $self, $dbh, $meta, $table ) = @_ if (0); + + return; +} # init_table_meta + +sub get_table_meta ($$$;$) +{ + my ( $self, $dbh, $table, $respect_case, @other ) = @_; + unless ( defined $respect_case ) + { + $respect_case = 0; + $table =~ s/^\"// and $respect_case = 1; # handle quoted identifiers + $table =~ s/\"$//; + } + + unless ($respect_case) + { + defined $dbh->{sql_meta_map}{$table} and $table = $dbh->{sql_meta_map}{$table}; + } + + my $meta = {}; + defined $dbh->{sql_meta}{$table} and $meta = $dbh->{sql_meta}{$table}; + + do_initialize: + unless ( $meta->{initialized} ) + { + $self->bootstrap_table_meta( $dbh, $meta, $table, @other ); + $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other ) + or return; + + if ( defined $meta->{table_name} and $table ne $meta->{table_name} ) + { + $dbh->{sql_meta_map}{$table} = $meta->{table_name}; + $table = $meta->{table_name}; + } + + # now we know a bit more - let's check if user can't use consequent spelling + # XXX add know issue about reset sql_identifier_case here ... + if ( defined $dbh->{sql_meta}{$table} ) + { + $meta = delete $dbh->{sql_meta}{$table}; # avoid endless loop + $meta->{initialized} + or goto do_initialize; + #or $meta->{sql_data_source}->complete_table_name( $meta, $table, $respect_case, @other ) + #or return; + } + + unless ( $dbh->{sql_meta}{$table}{initialized} ) + { + $self->init_table_meta( $dbh, $meta, $table ); + $meta->{initialized} = 1; + $dbh->{sql_meta}{$table} = $meta; + } + } + + return ( $table, $meta ); +} # get_table_meta + +my %reset_on_modify = (); +my %compat_map = (); + +sub register_reset_on_modify +{ + my ( $proto, $extra_resets ) = @_; + foreach my $cv ( keys %$extra_resets ) + { + #%reset_on_modify = ( %reset_on_modify, %$extra_resets ); + push @{ $reset_on_modify{$cv} }, + ref $extra_resets->{$cv} ? @{ $extra_resets->{$cv} } : ( $extra_resets->{$cv} ); + } + return; +} # register_reset_on_modify + +sub register_compat_map +{ + my ( $proto, $extra_compat_map ) = @_; + %compat_map = ( %compat_map, %$extra_compat_map ); + return; +} # register_compat_map + +sub get_table_meta_attr +{ + my ( $class, $meta, $attrib ) = @_; + exists $compat_map{$attrib} + and $attrib = $compat_map{$attrib}; + exists $meta->{$attrib} + and return $meta->{$attrib}; + return; +} # get_table_meta_attr + +sub set_table_meta_attr +{ + my ( $class, $meta, $attrib, $value ) = @_; + exists $compat_map{$attrib} + and $attrib = $compat_map{$attrib}; + $class->table_meta_attr_changed( $meta, $attrib, $value ); + $meta->{$attrib} = $value; +} # set_table_meta_attr + +sub table_meta_attr_changed +{ + my ( $class, $meta, $attrib, $value ) = @_; + defined $reset_on_modify{$attrib} + and delete @$meta{ @{ $reset_on_modify{$attrib} } } + and $meta->{initialized} = 0; +} # table_meta_attr_changed + +sub open_data +{ + my ( $self, $meta, $attrs, $flags ) = @_; + + $meta->{sql_data_source} + or croak "Table " . $meta->{table_name} . " not completely initialized"; + $meta->{sql_data_source}->open_data( $meta, $attrs, $flags ); + + return; +} # open_data + +# ====== SQL::Eval API ========================================================= + +sub new +{ + my ( $className, $data, $attrs, $flags ) = @_; + my $dbh = $data->{Database}; + + my ( $tblnm, $meta ) = $className->get_table_meta( $dbh, $attrs->{table}, 1 ) + or croak "Cannot find appropriate table '$attrs->{table}'"; + $attrs->{table} = $tblnm; + + # Being a bit dirty here, as SQL::Statement::Structure does not offer + # me an interface to the data I want + $flags->{createMode} && $data->{sql_stmt}{table_defs} + and $meta->{table_defs} = $data->{sql_stmt}{table_defs}; + + # open_file must be called before inherited new is invoked + # because column name mapping is initialized in constructor ... + $className->open_data( $meta, $attrs, $flags ); + + my $tbl = { + %{$attrs}, + meta => $meta, + col_names => $meta->{col_names} || [], + }; + return $className->SUPER::new($tbl); +} # new + +sub DESTROY +{ + my $self = shift; + my $meta = $self->{meta}; + $self->{row} and undef $self->{row}; + () +} + +1; + +#line 2234 diff --git a/apps/lib/DBI/Gofer/Execute.pm b/apps/lib/DBI/Gofer/Execute.pm new file mode 100644 index 0000000..59d132d --- /dev/null +++ b/apps/lib/DBI/Gofer/Execute.pm @@ -0,0 +1,714 @@ +#line 1 "DBI/Gofer/Execute.pm" +package DBI::Gofer::Execute; + +# $Id: Execute.pm 14282 2010-07-26 00:12:54Z David $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use Carp; + +use DBI qw(dbi_time); +use DBI::Gofer::Request; +use DBI::Gofer::Response; + +use base qw(DBI::Util::_accessor); + +our $VERSION = "0.014283"; + +our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common}; +our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods; + +our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr + +our $current_dbh; # the dbh we're using for this request + + +# set trace for server-side gofer +# Could use DBI_TRACE env var when it's an unrelated separate process +# but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream) +DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE}; + + +# define valid configuration attributes (args to new()) +# the values here indicate the basic type of values allowed +my %configuration_attributes = ( + gofer_execute_class => 1, + default_connect_dsn => 1, + forced_connect_dsn => 1, + default_connect_attributes => {}, + forced_connect_attributes => {}, + track_recent => 1, + check_request_sub => sub {}, + check_response_sub => sub {}, + forced_single_resultset => 1, + max_cached_dbh_per_drh => 1, + max_cached_sth_per_dbh => 1, + forced_response_attributes => {}, + forced_gofer_random => 1, + stats => {}, +); + +__PACKAGE__->mk_accessors( + keys %configuration_attributes +); + + + +sub new { + my ($self, $args) = @_; + $args->{default_connect_attributes} ||= {}; + $args->{forced_connect_attributes} ||= {}; + $args->{max_cached_sth_per_dbh} ||= 1000; + $args->{stats} ||= {}; + return $self->SUPER::new($args); +} + + +sub valid_configuration_attributes { + my $self = shift; + return { %configuration_attributes }; +} + + +my %extra_attr = ( + # Only referenced if the driver doesn't support private_attribute_info method. + # What driver-specific attributes should be returned for the driver being used? + # keyed by $dbh->{Driver}{Name} + # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others + # which would reduce processing/traffic for non-select statements + mysql => { + dbh => [qw( + mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid + mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id + )], + sth => [qw( + mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment + mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid + )], + # XXX this dbh_after_sth stuff is a temporary, but important, hack. + # should be done via hash instead of arrays where the hash value contains + # flags that can indicate which attributes need to be handled in this way + dbh_after_sth => [qw( + mysql_insertid + )], + }, + Pg => { + dbh => [qw( + pg_protocol pg_lib_version pg_server_version + pg_db pg_host pg_port pg_default_port + pg_options pg_pid + )], + sth => [qw( + pg_size pg_type pg_oid_status pg_cmd_status + )], + }, + Sybase => { + dbh => [qw( + syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string + )], + sth => [qw( + syb_types syb_proc_status syb_result_type + )], + }, + SQLite => { + dbh => [qw( + sqlite_version + )], + sth => [qw( + )], + }, + ExampleP => { + dbh => [qw( + examplep_private_dbh_attrib + )], + sth => [qw( + examplep_private_sth_attrib + )], + dbh_after_sth => [qw( + examplep_insertid + )], + }, +); + + +sub _connect { + my ($self, $request) = @_; + + my $stats = $self->{stats}; + + # discard CachedKids from time to time + if (++$stats->{_requests_served} % 1000 == 0 # XXX config? + and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh} + ) { + my %drivers = DBI->installed_drivers(); + while ( my ($driver, $drh) = each %drivers ) { + next unless my $CK = $drh->{CachedKids}; + next unless keys %$CK > $max_cached_dbh_per_drh; + next if $driver eq 'Gofer'; # ie transport=null when testing + DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver", + scalar keys %$CK, $self->{max_cached_dbh_per_drh}); + $_->{Active} && $_->disconnect for values %$CK; + %$CK = (); + } + } + + # local $ENV{...} can leak, so only do it if required + local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; + + my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call }; + $connect_method ||= 'connect_cached'; + $stats->{method_calls_dbh}->{$connect_method}++; + + # delete attributes we don't want to affect the server-side + # (Could just do this on client-side and trust the client. DoS?) + delete @{$attr}{qw(Profile InactiveDestroy AutoInactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)}; + + $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn + or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request"; + + my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || ''; + + my $connect_attr = { + + # the configured default attributes, if any + %{ $self->default_connect_attributes }, + + # pass username and password as attributes + # then they can be overridden by forced_connect_attributes + Username => $username, + Password => $password, + + # the requested attributes + %$attr, + + # force some attributes the way we'd like them + PrintWarn => $local_log, + PrintError => $local_log, + + # the configured default attributes, if any + %{ $self->forced_connect_attributes }, + + # RaiseError must be enabled + RaiseError => 1, + + # reset Executed flag (of the cached handle) so we can use it to tell + # if errors happened before the main part of the request was executed + Executed => 0, + + # ensure this connect_cached doesn't have the same args as the client + # because that causes subtle issues if in the same process (ie transport=null) + # include pid to avoid problems with forking (ie null transport in mod_perl) + # include gofer-random to avoid random behaviour leaking to other handles + dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random), + }; + + # XXX implement our own private connect_cached method? (with rate-limited ping) + my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr); + + $dbh->{ShowErrorStatement} = 1 if $local_log; + + # XXX should probably just be a Callbacks => arg to connect_cached + # with a cache of pre-built callback hooks (memoized, without $self) + if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) { + $self->_install_rand_callbacks($dbh, $random); + } + + my $CK = $dbh->{CachedKids}; + if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) { + %$CK = (); # clear all statement handles + } + + #$dbh->trace(0); + $current_dbh = $dbh; + return $dbh; +} + + +sub reset_dbh { + my ($self, $dbh) = @_; + $dbh->set_err(undef, undef); # clear any error state +} + + +sub new_response_with_err { + my ($self, $rv, $eval_error, $dbh) = @_; + # this is the usual way to create a response for both success and failure + # capture err+errstr etc and merge in $eval_error ($@) + + my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); + + if ($eval_error) { + $err ||= $DBI::stderr || 1; # ensure err is true + if ($errstr) { + $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr; + chomp $errstr; + $errstr .= "; $eval_error"; + } + else { + $errstr = $eval_error; + } + } + chomp $errstr if $errstr; + + my $flags; + # (XXX if we ever add transaction support then we'll need to take extra + # steps because the commit/rollback would reset Executed before we get here) + $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed}; + + my $response = DBI::Gofer::Response->new({ + rv => $rv, + err => $err, + errstr => $errstr, + state => $state, + flags => $flags, + }); + + return $response; +} + + +sub execute_request { + my ($self, $request) = @_; + # should never throw an exception + + DBI->trace_msg("-----> execute_request\n"); + + my @warnings; + local $SIG{__WARN__} = sub { + push @warnings, @_; + warn @_ if $local_log; + }; + + my $response = eval { + + if (my $check_request_sub = $self->check_request_sub) { + $request = $check_request_sub->($request, $self) + or die "check_request_sub failed"; + } + + my $version = $request->version || 0; + die ref($request)." version $version is not supported" + if $version < 0.009116 or $version >= 1; + + ($request->is_sth_request) + ? $self->execute_sth_request($request) + : $self->execute_dbh_request($request); + }; + $response ||= $self->new_response_with_err(undef, $@, $current_dbh); + + if (my $check_response_sub = $self->check_response_sub) { + # not protected with an eval so it can choose to throw an exception + my $new = $check_response_sub->($response, $self, $request); + $response = $new if ref $new; + } + + undef $current_dbh; + + $response->warnings(\@warnings) if @warnings; + DBI->trace_msg("<----- execute_request\n"); + return $response; +} + + +sub execute_dbh_request { + my ($self, $request) = @_; + my $stats = $self->{stats}; + + my $dbh; + my $rv_ref = eval { + $dbh = $self->_connect($request); + my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] + my $wantarray = shift @$args; + my $meth = shift @$args; + $stats->{method_calls_dbh}->{$meth}++; + my @rv = ($wantarray) + ? $dbh->$meth(@$args) + : scalar $dbh->$meth(@$args); + \@rv; + } || []; + my $response = $self->new_response_with_err($rv_ref, $@, $dbh); + + return $response if not $dbh; + + # does this request also want any dbh attributes returned? + if (my $dbh_attributes = $request->dbh_attributes) { + $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) ); + } + + if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) { + $stats->{method_calls_dbh}->{last_insert_id}++; + my $id = $dbh->last_insert_id( @$lid_args ); + $response->last_insert_id( $id ); + } + + if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) { + # dbh_method_call was probably a metadata method like table_info + # that returns a statement handle, so turn the $sth into resultset + my $sth = $rv_ref->[0]; + $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); + $response->rv("(sth)"); # don't try to return actual sth + } + + # we're finished with this dbh for this request + $self->reset_dbh($dbh); + + return $response; +} + + +sub gather_dbh_attributes { + my ($self, $dbh, $dbh_attributes) = @_; + my @req_attr_names = @$dbh_attributes; + if ($req_attr_names[0] eq '*') { # auto include std + private + shift @req_attr_names; + push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) }; + } + my %dbh_attr_values; + @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names); + + # XXX piggyback installed_methods onto dbh_attributes for now + $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods }; + + # XXX piggyback default_methods onto dbh_attributes for now + $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh); + + return \%dbh_attr_values; +} + + +sub _std_response_attribute_names { + my ($self, $h) = @_; + $h = tied(%$h) || $h; # switch to inner handle + + # cache the private_attribute_info data for each handle + # XXX might be better to cache it in the executor + # as it's unlikely to change + # or perhaps at least cache it in the dbh even for sth + # as the sth are typically very short lived + + my ($dbh, $h_type, $driver_name, @attr_names); + + if ($dbh = $h->{Database}) { # is an sth + + # does the dbh already have the answer cached? + return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth}; + + ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name}); + push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE); + } + else { # is a dbh + return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh}; + + ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h); + # explicitly add these because drivers may have different defaults + # add Name so the client gets the real Name of the connection + push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name); + } + + if (my $pai = $h->private_attribute_info) { + push @attr_names, keys %$pai; + } + else { + push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []}; + } + if (my $fra = $self->{forced_response_attributes}) { + push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []} + } + $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n"); + + # cache into the dbh even for sth, as the dbh is usually longer lived + return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names; +} + + +sub execute_sth_request { + my ($self, $request) = @_; + my $dbh; + my $sth; + my $last_insert_id; + my $stats = $self->{stats}; + + my $rv = eval { + $dbh = $self->_connect($request); + + my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] + shift @$args; # discard wantarray + my $meth = shift @$args; + $stats->{method_calls_sth}->{$meth}++; + $sth = $dbh->$meth(@$args); + my $last = '(sth)'; # a true value (don't try to return actual sth) + + # execute methods on the sth, e.g., bind_param & execute + if (my $calls = $request->sth_method_calls) { + for my $meth_call (@$calls) { + my $method = shift @$meth_call; + $stats->{method_calls_sth}->{$method}++; + $last = $sth->$method(@$meth_call); + } + } + + if (my $lid_args = $request->dbh_last_insert_id_args) { + $stats->{method_calls_sth}->{last_insert_id}++; + $last_insert_id = $dbh->last_insert_id( @$lid_args ); + } + + $last; + }; + my $response = $self->new_response_with_err($rv, $@, $dbh); + + return $response if not $dbh; + + $response->last_insert_id( $last_insert_id ) + if defined $last_insert_id; + + # even if the eval failed we still want to try to gather attribute values + # (XXX would be nice to be able to support streaming of results. + # which would reduce memory usage and latency for large results) + if ($sth) { + $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); + $sth->finish; + } + + # does this request also want any dbh attributes returned? + my $dbh_attr_set; + if (my $dbh_attributes = $request->dbh_attributes) { + $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes); + } + # XXX needs to be integrated with private_attribute_info() etc + if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) { + @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr); + } + $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set; + + $self->reset_dbh($dbh); + + return $response; +} + + +sub gather_sth_resultsets { + my ($self, $sth, $request, $response) = @_; + my $resultsets = eval { + + my $attr_names = $self->_std_response_attribute_names($sth); + my $sth_attr = {}; + $sth_attr->{$_} = 1 for @$attr_names; + + # let the client add/remove sth attributes + if (my $sth_result_attr = $request->sth_result_attr) { + $sth_attr->{$_} = $sth_result_attr->{$_} + for keys %$sth_result_attr; + } + my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr; + + my $row_count = 0; + my $rs_list = []; + while (1) { + my $rs = $self->fetch_result_set($sth, \@sth_attr); + push @$rs_list, $rs; + if (my $rows = $rs->{rowset}) { + $row_count += @$rows; + } + last if $self->{forced_single_resultset}; + last if !($sth->more_results || $sth->{syb_more_results}); + } + + my $stats = $self->{stats}; + $stats->{rows_returned_total} += $row_count; + $stats->{rows_returned_max} = $row_count + if $row_count > ($stats->{rows_returned_max}||0); + + $rs_list; + }; + $response->add_err(1, $@) if $@; + return $resultsets; +} + + +sub fetch_result_set { + my ($self, $sth, $sth_attr) = @_; + my %meta; + eval { + @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr); + # we assume @$sth_attr contains NUM_OF_FIELDS + $meta{rowset} = $sth->fetchall_arrayref() + if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT + # the fetchall_arrayref may fail with a 'not executed' kind of error + # because gather_sth_resultsets/fetch_result_set are called even if + # execute() failed, or even if there was no execute() call at all. + # The corresponding error goes into the resultset err, not the top-level + # response err, so in most cases this resultset err is never noticed. + }; + if ($@) { + chomp $@; + $meta{err} = $DBI::err || 1; + $meta{errstr} = $DBI::errstr || $@; + $meta{state} = $DBI::state; + } + return \%meta; +} + + +sub _get_default_methods { + my ($dbh) = @_; + # returns a ref to a hash of dbh method names for methods which the driver + # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer. + my $ImplementorClass = $dbh->{ImplementorClass} or die; + my %default_methods; + for my $method (@all_dbh_methods) { + my $dbi_sub = $all_dbh_methods{$method} || 42; + my $imp_sub = $ImplementorClass->can($method) || 42; + next if $imp_sub != $dbi_sub; + #warn("default $method\n"); + $default_methods{$method} = 1; + } + return \%default_methods; +} + + +# XXX would be nice to make this a generic DBI module +sub _install_rand_callbacks { + my ($self, $dbh, $dbi_gofer_random) = @_; + + my $callbacks = $dbh->{Callbacks} || {}; + my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {}; + + # return if we've already setup this handle with callbacks for these specs + return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random); + #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}"; + $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random; + + my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note); + my @specs = split /,/, $dbi_gofer_random; + for my $spec (@specs) { + if ($spec =~ m/^fail=(-?[.\d]+)%?$/) { + $fail_percent = $1; + $spec_part{fail} = $spec; + next; + } + if ($spec =~ m/^err=(-?\d+)$/) { + $fail_err = $1; + $spec_part{err} = $spec; + next; + } + if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) { + $delay_duration = $1; + $delay_percent = $2; + $spec_part{delay} = $spec; + next; + } + elsif ($spec !~ m/^(\w+|\*)$/) { + warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name"; + next; + } + + my $method = $spec; + if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) { + warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n"; + next; + } + unless (defined $fail_percent or defined $delay_percent) { + warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceded by 'fail=N' and/or 'delayN=N'"; + next; + } + + push @spec_note, join(",", values(%spec_part), $method); + $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err); + } + warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n" + if @spec_note; + $dbh->{Callbacks} = $callbacks; + $dbh->{private_gofer_rand_fail_callbacks} = $callbacks; +} + +my %_mk_rand_callback_seqn; + +sub _mk_rand_callback { + my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_; + my ($fail_modrate, $delay_modrate); + $fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent; + $delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent; + # note that $method may be "*" but that's not recommended or documented or wise + return sub { + my ($h) = @_; + my $seqn = ++$_mk_rand_callback_seqn{$method}; + my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent : + ($delay_percent < 0) ? !($seqn % $delay_modrate): 0; + my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent : + ($fail_percent < 0) ? !($seqn % $fail_modrate) : 0; + #no warnings 'uninitialized'; + #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay"; + if ($delay) { + my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n"; + # Note what's happening in a trace message. If the delay percent is an even + # number then use warn() instead so it's sent back to the client. + ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg); + select undef, undef, undef, $delay_duration; # allows floating point value + } + if ($fail) { + undef $_; # tell DBI to not call the method + # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr + # as it's checked for in a few places, such as the gofer retry logic + return $h->set_err($fail_err || $DBI::stderr, + "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)"); + } + return; + } +} + + +sub update_stats { + my ($self, + $request, $response, + $frozen_request, $frozen_response, + $time_received, + $store_meta, $other_meta, + ) = @_; + + # should always have a response object here + carp("No response object provided") unless $request; + + my $stats = $self->{stats}; + $stats->{frozen_request_max_bytes} = length($frozen_request) + if $frozen_request + && length($frozen_request) > ($stats->{frozen_request_max_bytes}||0); + $stats->{frozen_response_max_bytes} = length($frozen_response) + if $frozen_response + && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0); + + my $recent; + if (my $track_recent = $self->{track_recent}) { + $recent = { + request => $frozen_request, + response => $frozen_response, + time_received => $time_received, + duration => dbi_time()-$time_received, + # for any other info + ($store_meta) ? (meta => $store_meta) : (), + }; + $recent->{request_object} = $request + if !$frozen_request && $request; + $recent->{response_object} = $response + if !$frozen_response; + my @queues = ($stats->{recent_requests} ||= []); + push @queues, ($stats->{recent_errors} ||= []) + if !$response or $response->err; + for my $queue (@queues) { + push @$queue, $recent; + shift @$queue if @$queue > $track_recent; + } + } + return $recent; +} + + +1; +__END__ + +#line 901 diff --git a/apps/lib/DBI/Gofer/Request.pm b/apps/lib/DBI/Gofer/Request.pm new file mode 100644 index 0000000..eb31376 --- /dev/null +++ b/apps/lib/DBI/Gofer/Request.pm @@ -0,0 +1,182 @@ +#line 1 "DBI/Gofer/Request.pm" +package DBI::Gofer::Request; + +# $Id: Request.pm 12536 2009-02-24 22:37:09Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; + +use DBI qw(neat neat_list); + +use base qw(DBI::Util::_accessor); + +our $VERSION = "0.012537"; + +use constant GOf_REQUEST_IDEMPOTENT => 0x0001; +use constant GOf_REQUEST_READONLY => 0x0002; + +our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY); + + +__PACKAGE__->mk_accessors(qw( + version + flags + dbh_connect_call + dbh_method_call + dbh_attributes + dbh_last_insert_id_args + sth_method_calls + sth_result_attr +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($self, $args) = @_; + $args->{version} ||= $VERSION; + return $self->SUPER::new($args); +} + + +sub reset { + my ($self, $flags) = @_; + # remove everything except connect and version + %$self = ( + version => $self->{version}, + dbh_connect_call => $self->{dbh_connect_call}, + ); + $self->{flags} = $flags if $flags; +} + + +sub init_request { + my ($self, $method_and_args, $dbh) = @_; + $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 ); + $self->dbh_method_call($method_and_args); +} + + +sub is_sth_request { + return shift->{sth_result_attr}; +} + + +sub statements { + my $self = shift; + my @statements; + if (my $dbh_method_call = $self->dbh_method_call) { + my $statement_method_regex = qr/^(?:do|prepare)$/; + my (undef, $method, $arg1) = @$dbh_method_call; + push @statements, $arg1 if $method && $method =~ $statement_method_regex; + } + return @statements; +} + + +sub is_idempotent { + my $self = shift; + + if (my $flags = $self->flags) { + return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY); + } + + # else check if all statements are SELECT statement that don't include FOR UPDATE + my @statements = $self->statements; + # XXX this is very minimal for now, doesn't even allow comments before the select + # (and can't ever work for "exec stored_procedure_name" kinds of statements) + # XXX it also doesn't deal with multiple statements: prepare("select foo; update bar") + return 1 if @statements == grep { + m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi + } @statements; + + return 0; +} + + +sub summary_as_text { + my $self = shift; + my ($context) = @_; + my @s = ''; + + if ($context && %$context) { + my @keys = sort keys %$context; + push @s, join(", ", map { "$_=>".$context->{$_} } @keys); + } + + my ($method, $dsn, $user, $pass, $attr) = @{ $self->dbh_connect_call }; + $method ||= 'connect_cached'; + $pass = '***' if defined $pass; + my $tmp = ''; + if ($attr) { + $tmp = { %{$attr||{}} }; # copy so we can edit + $tmp->{Password} = '***' if exists $tmp->{Password}; + $tmp = "{ ".neat_list([ %$tmp ])." }"; + } + push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]), $tmp; + + if (my $flags = $self->flags) { + push @s, sprintf "flags: 0x%x", $flags; + } + + if (my $dbh_attr = $self->dbh_attributes) { + push @s, sprintf "dbh->FETCH: %s", @$dbh_attr + if @$dbh_attr; + } + + my ($wantarray, $meth, @args) = @{ $self->dbh_method_call }; + my $args = neat_list(\@args); + $args =~ s/\n+/ /g; + push @s, sprintf "dbh->%s(%s)", $meth, $args; + + if (my $lii_args = $self->dbh_last_insert_id_args) { + push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args); + } + + for my $call (@{ $self->sth_method_calls || [] }) { + my ($meth, @args) = @$call; + ($args = neat_list(\@args)) =~ s/\n+/ /g; + push @s, sprintf "sth->%s(%s)", $meth, $args; + } + + if (my $sth_attr = $self->sth_result_attr) { + push @s, sprintf "sth->FETCH: %s", %$sth_attr + if %$sth_attr; + } + + return join("\n\t", @s) . "\n"; +} + + +sub outline_as_text { # one-line version of summary_as_text + my $self = shift; + my @s = ''; + my $neatlen = 80; + + if (my $flags = $self->flags) { + push @s, sprintf "flags=0x%x", $flags; + } + + my (undef, $meth, @args) = @{ $self->dbh_method_call }; + push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); + + for my $call (@{ $self->sth_method_calls || [] }) { + my ($meth, @args) = @$call; + push @s, sprintf "%s(%s)", $meth, neat_list(\@args, $neatlen); + } + + my ($method, $dsn) = @{ $self->dbh_connect_call }; + push @s, "$method($dsn,...)"; # dsn last as it's usually less interesting + + (my $outline = join("; ", @s)) =~ s/\s+/ /g; # squish whitespace, incl newlines + return $outline; +} + +1; + +#line 201 diff --git a/apps/lib/DBI/Gofer/Response.pm b/apps/lib/DBI/Gofer/Response.pm new file mode 100644 index 0000000..f927041 --- /dev/null +++ b/apps/lib/DBI/Gofer/Response.pm @@ -0,0 +1,200 @@ +#line 1 "DBI/Gofer/Response.pm" +package DBI::Gofer::Response; + +# $Id: Response.pm 11565 2008-07-22 20:17:33Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; + +use Carp; +use DBI qw(neat neat_list); + +use base qw(DBI::Util::_accessor Exporter); + +our $VERSION = "0.011566"; + +use constant GOf_RESPONSE_EXECUTED => 0x0001; + +our @EXPORT = qw(GOf_RESPONSE_EXECUTED); + + +__PACKAGE__->mk_accessors(qw( + version + rv + err + errstr + state + flags + last_insert_id + dbh_attributes + sth_resultsets + warnings +)); +__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw( + meta +)); + + +sub new { + my ($self, $args) = @_; + $args->{version} ||= $VERSION; + chomp $args->{errstr} if $args->{errstr}; + return $self->SUPER::new($args); +} + + +sub err_errstr_state { + my $self = shift; + return @{$self}{qw(err errstr state)}; +} + +sub executed_flag_set { + my $flags = shift->flags + or return 0; + return $flags & GOf_RESPONSE_EXECUTED; +} + + +sub add_err { + my ($self, $err, $errstr, $state, $trace) = @_; + + # acts like the DBI's set_err method. + # this code copied from DBI::PurePerl's set_err method. + + chomp $errstr if $errstr; + $state ||= ''; + carp ref($self)."->add_err($err, $errstr, $state)" + if $trace and defined($err) || $errstr; + + my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr}, $self->{state}); + + if ($r_errstr) { + $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err + if $r_err && $err && $r_err ne $err; + $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state + if $r_state and $r_state ne "S1000" && $state && $r_state ne $state; + $r_errstr .= "\n$errstr" if $r_errstr ne $errstr; + } + else { + $r_errstr = $errstr; + } + + # assign if higher priority: err > "0" > "" > undef + my $err_changed; + if ($err # new error: so assign + or !defined $r_err # no existing warn/info: so assign + # new warn ("0" len 1) > info ("" len 0): so assign + or defined $err && length($err) > length($r_err) + ) { + $r_err = $err; + ++$err_changed; + } + + $r_state = ($state eq "00000") ? "" : $state + if $state && $err_changed; + + ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr, $r_state); + + return undef; +} + + +sub summary_as_text { + my $self = shift; + my ($context) = @_; + + my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); + + my @s = sprintf("\trv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); + $s[-1] .= sprintf(", err=%s, errstr=%s", $err, neat($errstr)) + if defined $err; + $s[-1] .= sprintf(", flags=0x%x", $self->{flags}) + if defined $self->{flags}; + + push @s, "last_insert_id=%s", $self->last_insert_id + if defined $self->last_insert_id; + + if (my $dbh_attr = $self->dbh_attributes) { + my @keys = sort keys %$dbh_attr; + push @s, sprintf "dbh= { %s }", join(", ", map { "$_=>".neat($dbh_attr->{$_},100) } @keys) + if @keys; + } + + for my $rs (@{$self->sth_resultsets || []}) { + my ($rowset, $err, $errstr, $state) + = @{$rs}{qw(rowset err errstr state)}; + my $summary = "rowset: "; + my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; + my $rows = $rowset ? @$rowset : 0; + if ($rowset || $NUM_OF_FIELDS > 0) { + $summary .= sprintf "%d rows, %d columns", $rows, $NUM_OF_FIELDS; + } + $summary .= sprintf ", err=%s, errstr=%s", $err, neat($errstr) if defined $err; + if ($rows) { + my $NAME = $rs->{NAME}; + # generate + my @colinfo = map { "$NAME->[$_]=".neat($rowset->[0][$_], 30) } 0..@{$NAME}-1; + $summary .= sprintf " [%s]", join ", ", @colinfo; + $summary .= ",..." if $rows > 1; + # we can be a little more helpful for Sybase/MSSQL user + $summary .= " syb_result_type=$rs->{syb_result_type}" + if $rs->{syb_result_type} and $rs->{syb_result_type} != 4040; + } + push @s, $summary; + } + for my $w (@{$self->warnings || []}) { + chomp $w; + push @s, "warning: $w"; + } + if ($context && %$context) { + my @keys = sort keys %$context; + push @s, join(", ", map { "$_=>".$context->{$_} } @keys); + } + return join("\n\t", @s). "\n"; +} + + +sub outline_as_text { # one-line version of summary_as_text + my $self = shift; + my ($context) = @_; + + my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err}, $self->{errstr}, $self->{state}); + + my $s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv)); + $s .= sprintf(", err=%s %s", $err, neat($errstr)) + if defined $err; + $s .= sprintf(", flags=0x%x", $self->{flags}) + if $self->{flags}; + + if (my $sth_resultsets = $self->sth_resultsets) { + $s .= sprintf(", %d resultsets ", scalar @$sth_resultsets); + + my @rs; + for my $rs (@{$self->sth_resultsets || []}) { + my $summary = ""; + my ($rowset, $err, $errstr) + = @{$rs}{qw(rowset err errstr)}; + my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0; + my $rows = $rowset ? @$rowset : 0; + if ($rowset || $NUM_OF_FIELDS > 0) { + $summary .= sprintf "%dr x %dc", $rows, $NUM_OF_FIELDS; + } + $summary .= sprintf "%serr %s %s", ($summary?", ":""), $err, neat($errstr) + if defined $err; + push @rs, $summary; + } + $s .= join "; ", map { "[$_]" } @rs; + } + + return $s; +} + + +1; + +#line 218 + diff --git a/apps/lib/DBI/Gofer/Serializer/Base.pm b/apps/lib/DBI/Gofer/Serializer/Base.pm new file mode 100644 index 0000000..28fc6bb --- /dev/null +++ b/apps/lib/DBI/Gofer/Serializer/Base.pm @@ -0,0 +1,45 @@ +#line 1 "DBI/Gofer/Serializer/Base.pm" +package DBI::Gofer::Serializer::Base; + +# $Id: Base.pm 9949 2007-09-18 09:38:15Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +#line 31 + + +use strict; +use warnings; + +use Carp qw(croak); + +our $VERSION = "0.009950"; + + +sub new { + my $class = shift; + my $deserializer_class = $class->deserializer_class; + return bless { deserializer_class => $deserializer_class } => $class; +} + +sub deserializer_class { + my $self = shift; + my $class = ref($self) || $self; + $class =~ s/^DBI::Gofer::Serializer:://; + return $class; +} + +sub serialize { + my $self = shift; + croak ref($self)." has not implemented the serialize method"; +} + +sub deserialize { + my $self = shift; + croak ref($self)." has not implemented the deserialize method"; +} + +1; diff --git a/apps/lib/DBI/Gofer/Serializer/DataDumper.pm b/apps/lib/DBI/Gofer/Serializer/DataDumper.pm new file mode 100644 index 0000000..935bc82 --- /dev/null +++ b/apps/lib/DBI/Gofer/Serializer/DataDumper.pm @@ -0,0 +1,37 @@ +#line 1 "DBI/Gofer/Serializer/DataDumper.pm" +package DBI::Gofer::Serializer::DataDumper; + +use strict; +use warnings; + +our $VERSION = "0.009950"; + +# $Id: DataDumper.pm 9949 2007-09-18 09:38:15Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +#line 33 + +use Data::Dumper; + +use base qw(DBI::Gofer::Serializer::Base); + + +sub serialize { + my $self = shift; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Useqq = 0; # enabling this disables xs + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Deparse = 0; + local $Data::Dumper::Purity = 0; + my $frozen = Data::Dumper::Dumper(shift); + return $frozen unless wantarray; + return ($frozen, $self->{deserializer_class}); +} + +1; diff --git a/apps/lib/DBI/Gofer/Serializer/Storable.pm b/apps/lib/DBI/Gofer/Serializer/Storable.pm new file mode 100644 index 0000000..5c48428 --- /dev/null +++ b/apps/lib/DBI/Gofer/Serializer/Storable.pm @@ -0,0 +1,39 @@ +#line 1 "DBI/Gofer/Serializer/Storable.pm" +package DBI::Gofer::Serializer::Storable; + +use strict; +use warnings; + +use base qw(DBI::Gofer::Serializer::Base); + +# $Id: Storable.pm 15585 2013-03-22 20:31:22Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +#line 38 + +use Storable qw(nfreeze thaw); + +our $VERSION = "0.015586"; + +use base qw(DBI::Gofer::Serializer::Base); + + +sub serialize { + my $self = shift; + local $Storable::forgive_me = 1; # for CODE refs etc + local $Storable::canonical = 1; # for go_cache + my $frozen = nfreeze(shift); + return $frozen unless wantarray; + return ($frozen, $self->{deserializer_class}); +} + +sub deserialize { + my $self = shift; + return thaw(shift); +} + +1; diff --git a/apps/lib/DBI/Gofer/Transport/Base.pm b/apps/lib/DBI/Gofer/Transport/Base.pm new file mode 100644 index 0000000..c35d589 --- /dev/null +++ b/apps/lib/DBI/Gofer/Transport/Base.pm @@ -0,0 +1,152 @@ +#line 1 "DBI/Gofer/Transport/Base.pm" +package DBI::Gofer::Transport::Base; + +# $Id: Base.pm 12536 2009-02-24 22:37:09Z Tim $ +# +# Copyright (c) 2007, Tim Bunce, Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + +use strict; +use warnings; + +use DBI; + +use base qw(DBI::Util::_accessor); + +use DBI::Gofer::Serializer::Storable; +use DBI::Gofer::Serializer::DataDumper; + +our $VERSION = "0.012537"; + +__PACKAGE__->mk_accessors(qw( + trace + keep_meta_frozen + serializer_obj +)); + + +# see also $ENV{DBI_GOFER_TRACE} in DBI::Gofer::Execute +sub _init_trace { (split(/=/,$ENV{DBI_GOFER_TRACE}||0))[0] } + + +sub new { + my ($class, $args) = @_; + $args->{trace} ||= $class->_init_trace; + $args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new(); + my $self = bless {}, $class; + $self->$_( $args->{$_} ) for keys %$args; + $self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace; + return $self; +} + +my $packet_header_text = "GoFER1:"; +my $packet_header_regex = qr/^GoFER(\d+):/; + + +sub _freeze_data { + my ($self, $data, $serializer, $skip_trace) = @_; + my $frozen = eval { + $self->_dump("freezing $self->{trace} ".ref($data), $data) + if !$skip_trace and $self->trace; + + local $data->{meta}; # don't include meta in serialization + $serializer ||= $self->{serializer_obj}; + my ($data, $deserializer_class) = $serializer->serialize($data); + + $packet_header_text . $data; + }; + if ($@) { + chomp $@; + die "Error freezing ".ref($data)." object: $@"; + } + + # stash the frozen data into the data structure itself + # to make life easy for the client caching code in DBD::Gofer::Transport::Base + $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen; + + return $frozen; +} +# public aliases used by subclasses +*freeze_request = \&_freeze_data; +*freeze_response = \&_freeze_data; + + +sub _thaw_data { + my ($self, $frozen_data, $serializer, $skip_trace) = @_; + my $data; + eval { + # check for and extract our gofer header and the info it contains + (my $frozen = $frozen_data) =~ s/$packet_header_regex//o + or die "does not have gofer header\n"; + my ($t_version) = $1; + $serializer ||= $self->{serializer_obj}; + $data = $serializer->deserialize($frozen); + die ref($serializer)."->deserialize didn't return a reference" + unless ref $data; + $data->{_transport}{version} = $t_version; + + $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen; + }; + if ($@) { + chomp(my $err = $@); + # remove extra noise from Storable + $err =~ s{ at \S+?/Storable.pm \(autosplit into \S+?/Storable/thaw.al\) line \d+(, \S+ line \d+)?}{}; + my $msg = sprintf "Error thawing: %s (data=%s)", $err, DBI::neat($frozen_data,50); + Carp::cluck("$msg, pid $$ stack trace follows:"); # XXX if $self->trace; + die $msg; + } + $self->_dump("thawing $self->{trace} ".ref($data), $data) + if !$skip_trace and $self->trace; + + return $data; +} +# public aliases used by subclasses +*thaw_request = \&_thaw_data; +*thaw_response = \&_thaw_data; + + +# this should probably live in the request and response classes +# and the tace level passed in +sub _dump { + my ($self, $label, $data) = @_; + + # don't dump the binary + local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen}; + + my $trace_level = $self->trace; + my $summary; + if ($trace_level >= 4) { + require Data::Dumper; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Useqq = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Deparse = 0; + local $Data::Dumper::Purity = 0; + $summary = Data::Dumper::Dumper($data); + } + elsif ($trace_level >= 2) { + $summary = eval { $data->summary_as_text } || $@ || "no summary available\n"; + } + else { + $summary = eval { $data->outline_as_text."\n" } || $@ || "no summary available\n"; + } + $self->trace_msg("$label: $summary"); +} + + +sub trace_msg { + my ($self, $msg, $min_level) = @_; + $min_level = 1 unless defined $min_level; + # transport trace level can override DBI's trace level + $min_level = 0 if $self->trace >= $min_level; + return DBI->trace_msg("gofer ".$msg, $min_level); +} + +1; + +#line 174 + diff --git a/apps/lib/DBI/PurePerl.pm b/apps/lib/DBI/PurePerl.pm new file mode 100644 index 0000000..66a92d0 --- /dev/null +++ b/apps/lib/DBI/PurePerl.pm @@ -0,0 +1,1112 @@ +#line 1 "DBI/PurePerl.pm" +######################################################################## +package # hide from PAUSE + DBI; +# vim: ts=8:sw=4 +######################################################################## +# +# Copyright (c) 2002,2003 Tim Bunce Ireland. +# +# See COPYRIGHT section in DBI.pm for usage and distribution rights. +# +######################################################################## +# +# Please send patches and bug reports to +# +# Jeff Zucker with cc to +# +######################################################################## + +use strict; +use Carp; +require Symbol; + +require utf8; +*utf8::is_utf8 = sub { # hack for perl 5.6 + require bytes; + return unless defined $_[0]; + return !(length($_[0]) == bytes::length($_[0])) +} unless defined &utf8::is_utf8; + +$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1; +$DBI::PurePerl::VERSION = "2.014286"; + +$DBI::neat_maxlen ||= 400; + +$DBI::tfh = Symbol::gensym(); +open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!"; +select( (select($DBI::tfh), $| = 1)[0] ); # autoflush + +# check for weaken support, used by ChildHandles +my $HAS_WEAKEN = eval { + require Scalar::Util; + # this will croak() if this Scalar::Util doesn't have a working weaken(). + Scalar::Util::weaken( my $test = [] ); + 1; +}; + +%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err); + +use constant SQL_ALL_TYPES => 0; +use constant SQL_ARRAY => 50; +use constant SQL_ARRAY_LOCATOR => 51; +use constant SQL_BIGINT => (-5); +use constant SQL_BINARY => (-2); +use constant SQL_BIT => (-7); +use constant SQL_BLOB => 30; +use constant SQL_BLOB_LOCATOR => 31; +use constant SQL_BOOLEAN => 16; +use constant SQL_CHAR => 1; +use constant SQL_CLOB => 40; +use constant SQL_CLOB_LOCATOR => 41; +use constant SQL_DATE => 9; +use constant SQL_DATETIME => 9; +use constant SQL_DECIMAL => 3; +use constant SQL_DOUBLE => 8; +use constant SQL_FLOAT => 6; +use constant SQL_GUID => (-11); +use constant SQL_INTEGER => 4; +use constant SQL_INTERVAL => 10; +use constant SQL_INTERVAL_DAY => 103; +use constant SQL_INTERVAL_DAY_TO_HOUR => 108; +use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; +use constant SQL_INTERVAL_DAY_TO_SECOND => 110; +use constant SQL_INTERVAL_HOUR => 104; +use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; +use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; +use constant SQL_INTERVAL_MINUTE => 105; +use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; +use constant SQL_INTERVAL_MONTH => 102; +use constant SQL_INTERVAL_SECOND => 106; +use constant SQL_INTERVAL_YEAR => 101; +use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; +use constant SQL_LONGVARBINARY => (-4); +use constant SQL_LONGVARCHAR => (-1); +use constant SQL_MULTISET => 55; +use constant SQL_MULTISET_LOCATOR => 56; +use constant SQL_NUMERIC => 2; +use constant SQL_REAL => 7; +use constant SQL_REF => 20; +use constant SQL_ROW => 19; +use constant SQL_SMALLINT => 5; +use constant SQL_TIME => 10; +use constant SQL_TIMESTAMP => 11; +use constant SQL_TINYINT => (-6); +use constant SQL_TYPE_DATE => 91; +use constant SQL_TYPE_TIME => 92; +use constant SQL_TYPE_TIMESTAMP => 93; +use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; +use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; +use constant SQL_UDT => 17; +use constant SQL_UDT_LOCATOR => 18; +use constant SQL_UNKNOWN_TYPE => 0; +use constant SQL_VARBINARY => (-3); +use constant SQL_VARCHAR => 12; +use constant SQL_WCHAR => (-8); +use constant SQL_WLONGVARCHAR => (-10); +use constant SQL_WVARCHAR => (-9); + +# for Cursor types +use constant SQL_CURSOR_FORWARD_ONLY => 0; +use constant SQL_CURSOR_KEYSET_DRIVEN => 1; +use constant SQL_CURSOR_DYNAMIC => 2; +use constant SQL_CURSOR_STATIC => 3; +use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY; + +use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */ +use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/ +use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */ +use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */ +use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/ +use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */ +use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */ +use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */ +use constant IMA_STUB => 0x0100; #/* do nothing eg $dbh->connected */ +use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */ +use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */ +use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */ +use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */ +use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/ +use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */ +use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */ +use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */ + +use constant DBIstcf_STRICT => 0x0001; +use constant DBIstcf_DISCARD_STRING => 0x0002; + +my %is_flag_attribute = map {$_ =>1 } qw( + Active + AutoCommit + ChopBlanks + CompatMode + Executed + Taint + TaintIn + TaintOut + InactiveDestroy + AutoInactiveDestroy + LongTruncOk + MultiThread + PrintError + PrintWarn + RaiseError + ShowErrorStatement + Warn +); +my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw( + ActiveKids + Attribution + BegunWork + CachedKids + Callbacks + ChildHandles + CursorName + Database + DebugDispatch + Driver + Err + Errstr + ErrCount + FetchHashKeyName + HandleError + HandleSetErr + ImplementorClass + Kids + LongReadLen + NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash + NULLABLE + NUM_OF_FIELDS + NUM_OF_PARAMS + Name + PRECISION + ParamValues + Profile + Provider + ReadOnly + RootClass + RowCacheSize + RowsInCache + SCALE + State + Statement + TYPE + Type + TraceLevel + Username + Version +)); + +sub valid_attribute { + my $attr = shift; + return 1 if $is_valid_attribute{$attr}; + return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter + return 0 +} + +my $initial_setup; +sub initial_setup { + $initial_setup = 1; + print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n" + if $DBI::dbi_debug & 0xF; + untie $DBI::err; + untie $DBI::errstr; + untie $DBI::state; + untie $DBI::rows; + #tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean +} + +sub _install_method { + my ( $caller, $method, $from, $param_hash ) = @_; + initial_setup() unless $initial_setup; + + my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/; + my $bitmask = $param_hash->{'O'} || 0; + my @pre_call_frag; + + return if $method_name eq 'can'; + + push @pre_call_frag, q{ + delete $h->{CachedKids}; + # ignore DESTROY for outer handle (DESTROY for inner likely to follow soon) + return if $h_inner; + # handle AutoInactiveDestroy and InactiveDestroy + $h->{InactiveDestroy} = 1 + if $h->{AutoInactiveDestroy} and $$ != $h->{dbi_pp_pid}; + $h->{Active} = 0 + if $h->{InactiveDestroy}; + # copy err/errstr/state up to driver so $DBI::err etc still work + if ($h->{err} and my $drh = $h->{Driver}) { + $drh->{$_} = $h->{$_} for ('err','errstr','state'); + } + } if $method_name eq 'DESTROY'; + + push @pre_call_frag, q{ + return $h->{$_[0]} if exists $h->{$_[0]}; + } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ? + + push @pre_call_frag, "return;" + if IMA_STUB & $bitmask; + + push @pre_call_frag, q{ + $method_name = pop @_; + } if IMA_FUNC_REDIRECT & $bitmask; + + push @pre_call_frag, q{ + my $parent_dbh = $h->{Database}; + } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask; + + push @pre_call_frag, q{ + warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems + $parent_dbh->{Statement} = $h->{Statement} if $parent_dbh; + } if IMA_COPY_UP_STMT & $bitmask; + + push @pre_call_frag, q{ + $h->{Executed} = 1; + $parent_dbh->{Executed} = 1 if $parent_dbh; + } if IMA_EXECUTE & $bitmask; + + push @pre_call_frag, q{ + %{ $h->{CachedKids} } = () if $h->{CachedKids}; + } if IMA_CLEAR_CACHED_KIDS & $bitmask; + + if (IMA_KEEP_ERR & $bitmask) { + push @pre_call_frag, q{ + my $keep_error = DBI::_err_hash($h); + }; + } + else { + my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) + ? q{= ($h->{dbi_pp_parent}->{dbi_pp_call_depth} && DBI::_err_hash($h)) } + : ""; + push @pre_call_frag, qq{ + my \$keep_error $ke_init; + }; + my $clear_error_code = q{ + #warn "$method_name cleared err"; + $h->{err} = $DBI::err = undef; + $h->{errstr} = $DBI::errstr = undef; + $h->{state} = $DBI::state = ''; + }; + $clear_error_code = q{ + printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n". + $h->{err}, $h->{err} + if defined $h->{err} && $DBI::dbi_debug & 0xF; + }. $clear_error_code + if exists $ENV{DBI_TRACE}; + push @pre_call_frag, ($ke_init) + ? qq{ unless (\$keep_error) { $clear_error_code }} + : $clear_error_code + unless $method_name eq 'set_err'; + } + + push @pre_call_frag, q{ + my $ErrCount = $h->{ErrCount}; + }; + + push @pre_call_frag, q{ + if (($DBI::dbi_debug & 0xF) >= 2) { + local $^W; + my $args = join " ", map { DBI::neat($_) } ($h, @_); + printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n"; + } + } if exists $ENV{DBI_TRACE}; # note use of 'exists' + + push @pre_call_frag, q{ + $h->{'dbi_pp_last_method'} = $method_name; + } unless exists $DBI::last_method_except{$method_name}; + + # --- post method call code fragments --- + my @post_call_frag; + + push @post_call_frag, q{ + if (my $trace_level = ($DBI::dbi_debug & 0xF)) { + if ($h->{err}) { + printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr}; + } + my $ret = join " ", map { DBI::neat($_) } @ret; + my $msg = " < $method_name= $ret"; + $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n"; + print $DBI::tfh $msg; + } + } if exists $ENV{DBI_TRACE}; # note use of exists + + push @post_call_frag, q{ + $h->{Executed} = 0; + if ($h->{BegunWork}) { + $h->{BegunWork} = 0; + $h->{AutoCommit} = 1; + } + } if IMA_END_WORK & $bitmask; + + push @post_call_frag, q{ + if ( ref $ret[0] and + UNIVERSAL::isa($ret[0], 'DBI::_::common') and + defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} ) + ) { + # copy up info/warn to drh so PrintWarn on connect is triggered + $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state}) + } + } if IMA_IS_FACTORY & $bitmask; + + push @post_call_frag, q{ + if ($keep_error) { + $keep_error = 0 + if $h->{ErrCount} > $ErrCount + or DBI::_err_hash($h) ne $keep_error; + } + + $DBI::err = $h->{err}; + $DBI::errstr = $h->{errstr}; + $DBI::state = $h->{state}; + + if ( !$keep_error + && defined(my $err = $h->{err}) + && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth}) + ) { + + my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError HandleError)}; + my $msg; + + if ($err && ($pe || $re || $he) # error + or (!$err && length($err) && $pw) # warning + ) { + my $last = ($DBI::last_method_except{$method_name}) + ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name; + my $errstr = $h->{errstr} || $DBI::errstr || $err || ''; + my $msg = sprintf "%s %s %s: %s", $imp, $last, + ($err eq "0") ? "warning" : "failed", $errstr; + + if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) { + $msg .= ' [for Statement "' . $Statement; + if (my $ParamValues = $h->FETCH('ParamValues')) { + $msg .= '" with ParamValues: '; + $msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef); + $msg .= "]"; + } + else { + $msg .= '"]'; + } + } + if ($err eq "0") { # is 'warning' (not info) + carp $msg if $pw; + } + else { + my $do_croak = 1; + if (my $subsub = $h->{'HandleError'}) { + $do_croak = 0 if &$subsub($msg,$h,$ret[0]); + } + if ($do_croak) { + printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n" + if ($DBI::dbi_debug & 0xF) >= 4; + carp $msg if $pe; + die $msg if $h->{RaiseError}; + } + } + } + } + }; + + + my $method_code = q[ + sub { + my $h = shift; + my $h_inner = tied(%$h); + $h = $h_inner if $h_inner; + + my $imp; + if ($method_name eq 'DESTROY') { + # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value" + # implying that tied() above lied to us, so we need to use eval + local $@; # protect $@ + $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction + } + else { + $imp = $h->{"ImplementorClass"} or do { + warn "Can't call $method_name method on handle $h after take_imp_data()\n" + if not exists $h->{Active}; + return; # or, more likely, global destruction + }; + } + + ] . join("\n", '', @pre_call_frag, '') . q[ + + my $call_depth = $h->{'dbi_pp_call_depth'} + 1; + local ($h->{'dbi_pp_call_depth'}) = $call_depth; + + my @ret; + my $sub = $imp->can($method_name); + if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) { + push @_, $method_name; + } + if ($sub) { + (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_)); + } + else { + # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc + # which would then let Multiplex pass PurePerl tests, but some + # hook into install_method may be better. + croak "Can't locate DBI object method \"$method_name\" via package \"$imp\"" + if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[; + } + + ] . join("\n", '', @post_call_frag, '') . q[ + + return (wantarray) ? @ret : $ret[0]; + } + ]; + no strict qw(refs); + my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code}; + warn "$@\n$method_code\n" if $@; + die "$@\n$method_code\n" if $@; + *$method = $code_ref; + if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool + my $l=0; # show line-numbered code for method + warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code); + } +} + + +sub _new_handle { + my ($class, $parent, $attr, $imp_data, $imp_class) = @_; + + DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n") + if $DBI::dbi_debug >= 3; + + $attr->{ImplementorClass} = $imp_class + or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given"); + + # This is how we create a DBI style Object: + # %outer gets tied to %$attr (which becomes the 'inner' handle) + my (%outer, $i, $h); + $i = tie %outer, $class, $attr; # ref to inner hash (for driver) + $h = bless \%outer, $class; # ref to outer hash (for application) + # The above tie and bless may migrate down into _setup_handle()... + # Now add magic so DBI method dispatch works + DBI::_setup_handle($h, $imp_class, $parent, $imp_data); + return $h unless wantarray; + return ($h, $i); +} + +sub _setup_handle { + my($h, $imp_class, $parent, $imp_data) = @_; + my $h_inner = tied(%$h) || $h; + if (($DBI::dbi_debug & 0xF) >= 4) { + local $^W; + print $DBI::tfh " _setup_handle(@_)\n"; + } + $h_inner->{"imp_data"} = $imp_data; + $h_inner->{"ImplementorClass"} = $imp_class; + $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained + if ($parent) { + foreach (qw( + RaiseError PrintError PrintWarn HandleError HandleSetErr + Warn LongTruncOk ChopBlanks AutoCommit ReadOnly + ShowErrorStatement FetchHashKeyName LongReadLen CompatMode + )) { + $h_inner->{$_} = $parent->{$_} + if exists $parent->{$_} && !exists $h_inner->{$_}; + } + if (ref($parent) =~ /::db$/) { # is sth + $h_inner->{Database} = $parent; + $parent->{Statement} = $h_inner->{Statement}; + $h_inner->{NUM_OF_PARAMS} = 0; + $h_inner->{Active} = 0; # driver sets true when there's data to fetch + } + elsif (ref($parent) =~ /::dr$/){ # is dbh + $h_inner->{Driver} = $parent; + $h_inner->{Active} = 0; + } + else { + warn "panic: ".ref($parent); # should never happen + } + $h_inner->{dbi_pp_parent} = $parent; + + # add to the parent's ChildHandles + if ($HAS_WEAKEN) { + my $handles = $parent->{ChildHandles} ||= []; + push @$handles, $h; + Scalar::Util::weaken($handles->[-1]); + # purge destroyed handles occasionally + if (@$handles % 120 == 0) { + @$handles = grep { defined } @$handles; + Scalar::Util::weaken($_) for @$handles; # re-weaken after grep + } + } + } + else { # setting up a driver handle + $h_inner->{Warn} = 1; + $h_inner->{PrintWarn} = 1; + $h_inner->{AutoCommit} = 1; + $h_inner->{TraceLevel} = 0; + $h_inner->{CompatMode} = (1==0); + $h_inner->{FetchHashKeyName} ||= 'NAME'; + $h_inner->{LongReadLen} ||= 80; + $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN; + $h_inner->{Type} ||= 'dr'; + $h_inner->{Active} = 1; + } + $h_inner->{"dbi_pp_call_depth"} = 0; + $h_inner->{"dbi_pp_pid"} = $$; + $h_inner->{ErrCount} = 0; +} + +sub constant { + warn "constant(@_) called unexpectedly"; return undef; +} + +sub trace { + my ($h, $level, $file) = @_; + $level = $h->parse_trace_flags($level) + if defined $level and !DBI::looks_like_number($level); + my $old_level = $DBI::dbi_debug; + _set_trace_file($file) if $level; + if (defined $level) { + $DBI::dbi_debug = $level; + print $DBI::tfh " DBI $DBI::VERSION (PurePerl) " + . "dispatch trace level set to $DBI::dbi_debug\n" + if $DBI::dbi_debug & 0xF; + } + _set_trace_file($file) if !$level; + return $old_level; +} + +sub _set_trace_file { + my ($file) = @_; + # + # DAA add support for filehandle inputs + # + # DAA required to avoid closing a prior fh trace() + $DBI::tfh = undef unless $DBI::tfh_needs_close; + + if (ref $file eq 'GLOB') { + $DBI::tfh = $file; + select((select($DBI::tfh), $| = 1)[0]); + $DBI::tfh_needs_close = 0; + return 1; + } + if ($file && ref \$file eq 'GLOB') { + $DBI::tfh = *{$file}{IO}; + select((select($DBI::tfh), $| = 1)[0]); + $DBI::tfh_needs_close = 0; + return 1; + } + $DBI::tfh_needs_close = 1; + if (!$file || $file eq 'STDERR') { + open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!"; + } + elsif ($file eq 'STDOUT') { + open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!"; + } + else { + open $DBI::tfh, ">>$file" or carp "Can't open $file: $!"; + } + select((select($DBI::tfh), $| = 1)[0]); + return 1; +} +sub _get_imp_data { shift->{"imp_data"}; } +sub _svdump { } +sub dump_handle { + my ($h,$msg,$level) = @_; + $msg||="dump_handle $h"; + print $DBI::tfh "$msg:\n"; + for my $attrib (sort keys %$h) { + print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n"; + } +} + +sub _handles { + my $h = shift; + my $h_inner = tied %$h; + if ($h_inner) { # this is okay + return $h unless wantarray; + return ($h, $h_inner); + } + # XXX this isn't okay... we have an inner handle but + # currently have no way to get at its outer handle, + # so we just warn and return the inner one for both... + Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl"); + return $h unless wantarray; + return ($h,$h); +} + +sub hash { + my ($key, $type) = @_; + my ($hash); + if (!$type) { + $hash = 0; + # XXX The C version uses the "char" type, which could be either + # signed or unsigned. I use signed because so do the two + # compilers on my system. + for my $char (unpack ("c*", $key)) { + $hash = $hash * 33 + $char; + } + $hash &= 0x7FFFFFFF; # limit to 31 bits + $hash |= 0x40000000; # set bit 31 + return -$hash; # return negative int + } + elsif ($type == 1) { # Fowler/Noll/Vo hash + # see http://www.isthe.com/chongo/tech/comp/fnv/ + require Math::BigInt; # feel free to reimplement w/o BigInt! + (my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01" + if ($version >= 1.56) { + $hash = Math::BigInt->new(0x811c9dc5); + for my $uchar (unpack ("C*", $key)) { + # multiply by the 32 bit FNV magic prime mod 2^64 + $hash = ($hash * 0x01000193) & 0xffffffff; + # xor the bottom with the current octet + $hash ^= $uchar; + } + # cast to int + return unpack "i", pack "i", $hash; + } + croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)"); + } + else { + croak("bad hash type $type"); + } +} + +sub looks_like_number { + my @new = (); + for my $thing(@_) { + if (!defined $thing or $thing eq '') { + push @new, undef; + } + else { + push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; + } + } + return (@_ >1) ? @new : $new[0]; +} + +sub neat { + my $v = shift; + return "undef" unless defined $v; + my $quote = q{"}; + if (not utf8::is_utf8($v)) { + return $v if (($v & ~ $v) eq "0"); # is SvNIOK + $quote = q{'}; + } + my $maxlen = shift || $DBI::neat_maxlen; + if ($maxlen && $maxlen < length($v) + 2) { + $v = substr($v,0,$maxlen-5); + $v .= '...'; + } + $v =~ s/[^[:print:]]/./g; + return "$quote$v$quote"; +} + +sub sql_type_cast { + my (undef, $sql_type, $flags) = @_; + + return -1 unless defined $_[0]; + + my $cast_ok = 1; + + my $evalret = eval { + use warnings FATAL => qw(numeric); + if ($sql_type == SQL_INTEGER) { + my $dummy = $_[0] + 0; + return 1; + } + elsif ($sql_type == SQL_DOUBLE) { + my $dummy = $_[0] + 0.0; + return 1; + } + elsif ($sql_type == SQL_NUMERIC) { + my $dummy = $_[0] + 0.0; + return 1; + } + else { + return -2; + } + } or $^W && warn $@; # XXX warnings::warnif("numeric", $@) ? + + return $evalret if defined($evalret) && ($evalret == -2); + $cast_ok = 0 unless $evalret; + + # DBIstcf_DISCARD_STRING not supported for PurePerl currently + + return 2 if $cast_ok; + return 0 if $flags & DBIstcf_STRICT; + return 1; +} + +sub dbi_time { + return time(); +} + +sub DBI::st::TIEHASH { bless $_[1] => $_[0] }; + +sub _concat_hash_sorted { + my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; + # $num_sort: 0=lexical, 1=numeric, undef=try to guess + + return undef unless defined $hash_ref; + die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; + my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); + my $string = ''; + for my $key (@$keys) { + $string .= $pair_separator if length $string > 0; + my $value = $hash_ref->{$key}; + if ($use_neat) { + $value = DBI::neat($value, 0); + } + else { + $value = (defined $value) ? "'$value'" : 'undef'; + } + $string .= $key . $kv_separator . $value; + } + return $string; +} + +sub _get_sorted_hash_keys { + my ($hash_ref, $num_sort) = @_; + if (not defined $num_sort) { + my $sort_guess = 1; + $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess + for keys %$hash_ref; + $num_sort = $sort_guess; + } + + my @keys = keys %$hash_ref; + no warnings 'numeric'; + my @sorted = ($num_sort) + ? sort { $a <=> $b or $a cmp $b } @keys + : sort @keys; + return \@sorted; +} + +sub _err_hash { + return 1 unless defined $_[0]->{err}; + return "$_[0]->{err} $_[0]->{errstr}" +} + + +package + DBI::var; + +sub FETCH { + my($key)=shift; + return $DBI::err if $$key eq '*err'; + return $DBI::errstr if $$key eq '&errstr'; + Carp::confess("FETCH $key not supported when using DBI::PurePerl"); +} + +package + DBD::_::common; + +sub swap_inner_handle { + my ($h1, $h2) = @_; + # can't make this work till we can get the outer handle from the inner one + # probably via a WeakRef + return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl"); +} + +sub trace { # XXX should set per-handle level, not global + my ($h, $level, $file) = @_; + $level = $h->parse_trace_flags($level) + if defined $level and !DBI::looks_like_number($level); + my $old_level = $DBI::dbi_debug; + DBI::_set_trace_file($file) if defined $file; + if (defined $level) { + $DBI::dbi_debug = $level; + if ($DBI::dbi_debug) { + printf $DBI::tfh + " %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n", + $h, $DBI::dbi_debug; + print $DBI::tfh " Full trace not available because DBI_TRACE is not in environment\n" + unless exists $ENV{DBI_TRACE}; + } + } + return $old_level; +} +*debug = \&trace; *debug = \&trace; # twice to avoid typo warning + +sub FETCH { + my($h,$key)= @_; + my $v = $h->{$key}; + #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n"); + return $v if defined $v; + if ($key =~ /^NAME_.c$/) { + my $cols = $h->FETCH('NAME'); + return undef unless $cols; + my @lcols = map { lc $_ } @$cols; + $h->{NAME_lc} = \@lcols; + my @ucols = map { uc $_ } @$cols; + $h->{NAME_uc} = \@ucols; + return $h->FETCH($key); + } + if ($key =~ /^NAME.*_hash$/) { + my $i=0; + for my $c(@{$h->FETCH('NAME')||[]}) { + $h->{'NAME_hash'}->{$c} = $i; + $h->{'NAME_lc_hash'}->{"\L$c"} = $i; + $h->{'NAME_uc_hash'}->{"\U$c"} = $i; + $i++; + } + return $h->{$key}; + } + if (!defined $v && !exists $h->{$key}) { + return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint'; + return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef + return $DBI::dbi_debug if $key eq 'TraceLevel'; + return [] if $key eq 'ChildHandles' && $HAS_WEAKEN; + if ($key eq 'Type') { + return "dr" if $h->isa('DBI::dr'); + return "db" if $h->isa('DBI::db'); + return "st" if $h->isa('DBI::st'); + Carp::carp( sprintf "Can't determine Type for %s",$h ); + } + if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) { + local $^W; # hide undef warnings + Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key ) + } + } + return $v; +} +sub STORE { + my ($h,$key,$value) = @_; + if ($key eq 'AutoCommit') { + Carp::croak("DBD driver has not implemented the AutoCommit attribute") + unless $value == -900 || $value == -901; + $value = ($value == -901); + } + elsif ($key =~ /^Taint/ ) { + Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key) + if $value; + } + elsif ($key eq 'TraceLevel') { + $h->trace($value); + return 1; + } + elsif ($key eq 'NUM_OF_FIELDS') { + $h->{$key} = $value; + if ($value) { + my $fbav = DBD::_::st::dbih_setup_fbav($h); + @$fbav = (undef) x $value if @$fbav != $value; + } + return 1; + } + elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) { + Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s", + $h,$key,$value); + } + $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value; + Scalar::Util::weaken($h->{$key}) if $key eq 'CachedKids'; + return 1; +} +sub DELETE { + my ($h, $key) = @_; + return $h->FETCH($key) unless $key =~ /^private_/; + return delete $h->{$key}; +} +sub err { return shift->{err} } +sub errstr { return shift->{errstr} } +sub state { return shift->{state} } +sub set_err { + my ($h, $errnum,$msg,$state, $method, $rv) = @_; + $h = tied(%$h) || $h; + + if (my $hss = $h->{HandleSetErr}) { + return if $hss->($h, $errnum, $msg, $state, $method); + } + + if (!defined $errnum) { + $h->{err} = $DBI::err = undef; + $h->{errstr} = $DBI::errstr = undef; + $h->{state} = $DBI::state = ''; + return; + } + + if ($h->{errstr}) { + $h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum + if $h->{err} && $errnum && $h->{err} ne $errnum; + $h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state + if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state; + $h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg; + $DBI::errstr = $h->{errstr}; + } + else { + $h->{errstr} = $DBI::errstr = $msg; + } + + # assign if higher priority: err > "0" > "" > undef + my $err_changed; + if ($errnum # new error: so assign + or !defined $h->{err} # no existing warn/info: so assign + # new warn ("0" len 1) > info ("" len 0): so assign + or defined $errnum && length($errnum) > length($h->{err}) + ) { + $h->{err} = $DBI::err = $errnum; + ++$h->{ErrCount} if $errnum; + ++$err_changed; + } + + if ($err_changed) { + $state ||= "S1000" if $DBI::err; + $h->{state} = $DBI::state = ($state eq "00000") ? "" : $state + if $state; + } + + if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY) + $p->{err} = $DBI::err; + $p->{errstr} = $DBI::errstr; + $p->{state} = $DBI::state; + } + + $h->{'dbi_pp_last_method'} = $method; + return $rv; # usually undef +} +sub trace_msg { + my ($h, $msg, $minlevel)=@_; + $minlevel = 1 unless defined $minlevel; + return unless $minlevel <= ($DBI::dbi_debug & 0xF); + print $DBI::tfh $msg; + return 1; +} +sub private_data { + warn "private_data @_"; +} +sub take_imp_data { + my $dbh = shift; + # A reasonable default implementation based on the one in DBI.xs. + # Typically a pure-perl driver would have their own take_imp_data method + # that would delete all but the essential items in the hash before ending with: + # return $dbh->SUPER::take_imp_data(); + # Of course it's useless if the driver doesn't also implement support for + # the dbi_imp_data attribute to the connect() method. + require Storable; + croak("Can't take_imp_data from handle that's not Active") + unless $dbh->{Active}; + for my $sth (@{ $dbh->{ChildHandles} || [] }) { + next unless $sth; + $sth->finish if $sth->{Active}; + bless $sth, 'DBI::zombie'; + } + delete $dbh->{$_} for (keys %is_valid_attribute); + delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh; + # warn "@{[ %$dbh ]}"; + local $Storable::forgive_me = 1; # in case there are some CODE refs + my $imp_data = Storable::freeze($dbh); + # XXX um, should probably untie here - need to check dispatch behaviour + return $imp_data; +} +sub rows { + return -1; # always returns -1 here, see DBD::_::st::rows below +} +sub DESTROY { +} + +package + DBD::_::dr; + +sub dbixs_revision { + return 0; +} + +package + DBD::_::db; + +sub connected { +} + + +package + DBD::_::st; + +sub fetchrow_arrayref { + my $h = shift; + # if we're here then driver hasn't implemented fetch/fetchrow_arrayref + # so we assume they've implemented fetchrow_array and call that instead + my @row = $h->fetchrow_array or return; + return $h->_set_fbav(\@row); +} +# twice to avoid typo warning +*fetch = \&fetchrow_arrayref; *fetch = \&fetchrow_arrayref; + +sub fetchrow_array { + my $h = shift; + # if we're here then driver hasn't implemented fetchrow_array + # so we assume they've implemented fetch/fetchrow_arrayref + my $row = $h->fetch or return; + return @$row; +} +*fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array; + +sub fetchrow_hashref { + my $h = shift; + my $row = $h->fetch or return; + my $FetchCase = shift; + my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME'; + my $FetchHashKeys = $h->FETCH($FetchHashKeyName); + my %rowhash; + @rowhash{ @$FetchHashKeys } = @$row; + return \%rowhash; +} +sub dbih_setup_fbav { + my $h = shift; + return $h->{'_fbav'} || do { + $DBI::rows = $h->{'_rows'} = 0; + my $fields = $h->{'NUM_OF_FIELDS'} + or DBI::croak("NUM_OF_FIELDS not set"); + my @row = (undef) x $fields; + \@row; + }; +} +sub _get_fbav { + my $h = shift; + my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h); + $DBI::rows = ++$h->{'_rows'}; + return $av; +} +sub _set_fbav { + my $h = shift; + my $fbav = $h->{'_fbav'}; + if ($fbav) { + $DBI::rows = ++$h->{'_rows'}; + } + else { + $fbav = $h->_get_fbav; + } + my $row = shift; + if (my $bc = $h->{'_bound_cols'}) { + for my $i (0..@$row-1) { + my $bound = $bc->[$i]; + $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i]; + } + } + else { + @$fbav = @$row; + } + return $fbav; +} +sub bind_col { + my ($h, $col, $value_ref,$from_bind_columns) = @_; + my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav() + my $num_of_fields = @$fbav; + DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)") + if $col < 1 or $col > $num_of_fields; + return 1 if not defined $value_ref; # ie caller is just trying to set TYPE + DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar") + unless ref $value_ref eq 'SCALAR'; + $h->{'_bound_cols'}->[$col-1] = $value_ref; + return 1; +} +sub finish { + my $h = shift; + $h->{'_fbav'} = undef; + $h->{'Active'} = 0; + return 1; +} +sub rows { + my $h = shift; + my $rows = $h->{'_rows'}; + return -1 unless defined $rows; + return $rows; +} + +1; +__END__ + +#line 1280 diff --git a/apps/lib/DBI/SQL/Nano.pm b/apps/lib/DBI/SQL/Nano.pm new file mode 100644 index 0000000..5b3de44 --- /dev/null +++ b/apps/lib/DBI/SQL/Nano.pm @@ -0,0 +1,812 @@ +#line 1 "DBI/SQL/Nano.pm" +####################################################################### +# +# DBI::SQL::Nano - a very tiny SQL engine +# +# Copyright (c) 2010 by Jens Rehsack < rehsack AT cpan.org > +# Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org > +# +# All rights reserved. +# +# You may freely distribute and/or modify this module under the terms +# of either the GNU General Public License (GPL) or the Artistic License, +# as specified in the Perl README file. +# +# See the pod at the bottom of this file for help information +# +####################################################################### + +####################### +package DBI::SQL::Nano; +####################### +use strict; +use warnings; +use vars qw( $VERSION $versions ); + +use Carp qw(croak); + +require DBI; # for looks_like_number() + +BEGIN +{ + $VERSION = "1.015544"; + + $versions->{nano_version} = $VERSION; + if ( $ENV{DBI_SQL_NANO} || !eval { require SQL::Statement; $SQL::Statement::VERSION ge '1.400' } ) + { + @DBI::SQL::Nano::Statement::ISA = qw(DBI::SQL::Nano::Statement_); + @DBI::SQL::Nano::Table::ISA = qw(DBI::SQL::Nano::Table_); + } + else + { + @DBI::SQL::Nano::Statement::ISA = qw( SQL::Statement ); + @DBI::SQL::Nano::Table::ISA = qw( SQL::Eval::Table); + $versions->{statement_version} = $SQL::Statement::VERSION; + } +} + +################################### +package DBI::SQL::Nano::Statement_; +################################### + +use Carp qw(croak); +use Errno; + +if ( eval { require Clone; } ) +{ + Clone->import("clone"); +} +else +{ + require Storable; # in CORE since 5.7.3 + *clone = \&Storable::dclone; +} + +sub new +{ + my ( $class, $sql ) = @_; + my $self = {}; + bless $self, $class; + return $self->prepare($sql); +} + +##################################################################### +# PREPARE +##################################################################### +sub prepare +{ + my ( $self, $sql ) = @_; + $sql =~ s/\s+$//; + $sql =~ s/\s*;$//; + for ($sql) + { + /^\s*CREATE\s+TABLE\s+(.*?)\s*\((.+)\)\s*$/is + && do + { + $self->{command} = 'CREATE'; + $self->{table_name} = $1; + defined $2 and $2 ne "" and + $self->{column_names} = parse_coldef_list($2); + $self->{column_names} or croak "Can't find columns"; + }; + /^\s*DROP\s+TABLE\s+(IF\s+EXISTS\s+)?(.*?)\s*$/is + && do + { + $self->{command} = 'DROP'; + $self->{table_name} = $2; + defined $1 and $1 ne "" and + $self->{ignore_missing_table} = 1; + }; + /^\s*SELECT\s+(.*?)\s+FROM\s+(\S+)((.*))?/is + && do + { + $self->{command} = 'SELECT'; + defined $1 and $1 ne "" and + $self->{column_names} = parse_comma_list($1); + $self->{column_names} or croak "Can't find columns"; + $self->{table_name} = $2; + if ( my $clauses = $4 ) + { + if ( $clauses =~ /^(.*)\s+ORDER\s+BY\s+(.*)$/is ) + { + $clauses = $1; + $self->{order_clause} = $self->parse_order_clause($2); + } + $self->{where_clause} = $self->parse_where_clause($clauses) if ($clauses); + } + }; + /^\s*INSERT\s+(?:INTO\s+)?(\S+)\s*(\((.*?)\))?\s*VALUES\s*\((.+)\)/is + && do + { + $self->{command} = 'INSERT'; + $self->{table_name} = $1; + defined $2 and $2 ne "" and + $self->{column_names} = parse_comma_list($2); + defined $4 and $4 ne "" and + $self->{values} = $self->parse_values_list($4); + $self->{values} or croak "Can't parse values"; + }; + /^\s*DELETE\s+FROM\s+(\S+)((.*))?/is + && do + { + $self->{command} = 'DELETE'; + $self->{table_name} = $1; + defined $3 and $3 ne "" and + $self->{where_clause} = $self->parse_where_clause($3); + }; + /^\s*UPDATE\s+(\S+)\s+SET\s+(.+)(\s+WHERE\s+.+)/is + && do + { + $self->{command} = 'UPDATE'; + $self->{table_name} = $1; + defined $2 and $2 ne "" and + $self->parse_set_clause($2); + defined $3 and $3 ne "" and + $self->{where_clause} = $self->parse_where_clause($3); + }; + } + croak "Couldn't parse" unless ( $self->{command} and $self->{table_name} ); + return $self; +} + +sub parse_order_clause +{ + my ( $self, $str ) = @_; + my @clause = split /\s+/, $str; + return { $clause[0] => 'ASC' } if ( @clause == 1 ); + croak "Bad ORDER BY clause '$str'" if ( @clause > 2 ); + $clause[1] ||= ''; + return { $clause[0] => uc $clause[1] } + if $clause[1] =~ /^ASC$/i + or $clause[1] =~ /^DESC$/i; + croak "Bad ORDER BY clause '$clause[1]'"; +} + +sub parse_coldef_list +{ # check column definitions + my @col_defs; + for ( split ',', shift ) + { + my $col = clean_parse_str($_); + if ( $col =~ /^(\S+?)\s+.+/ ) + { # doesn't check what it is + $col = $1; # just checks if it exists + } + else + { + croak "No column definition for '$_'"; + } + push @col_defs, $col; + } + return \@col_defs; +} + +sub parse_comma_list +{ + [ map { clean_parse_str($_) } split( ',', shift ) ]; +} +sub clean_parse_str { local $_ = shift; s/\(//; s/\)//; s/^\s+//; s/\s+$//; $_; } + +sub parse_values_list +{ + my ( $self, $str ) = @_; + [ map { $self->parse_value( clean_parse_str($_) ) } split( ',', $str ) ]; +} + +sub parse_set_clause +{ + my $self = shift; + my @cols = split /,/, shift; + my $set_clause; + for my $col (@cols) + { + my ( $col_name, $value ) = $col =~ /^\s*(.+?)\s*=\s*(.+?)\s*$/s; + push @{ $self->{column_names} }, $col_name; + push @{ $self->{values} }, $self->parse_value($value); + } + croak "Can't parse set clause" unless ( $self->{column_names} and $self->{values} ); +} + +sub parse_value +{ + my ( $self, $str ) = @_; + return unless ( defined $str ); + $str =~ s/\s+$//; + $str =~ s/^\s+//; + if ( $str =~ /^\?$/ ) + { + push @{ $self->{params} }, '?'; + return { + value => '?', + type => 'placeholder' + }; + } + return { + value => undef, + type => 'NULL' + } if ( $str =~ /^NULL$/i ); + return { + value => $1, + type => 'string' + } if ( $str =~ /^'(.+)'$/s ); + return { + value => $str, + type => 'number' + } if ( DBI::looks_like_number($str) ); + return { + value => $str, + type => 'column' + }; +} + +sub parse_where_clause +{ + my ( $self, $str ) = @_; + $str =~ s/\s+$//; + if ( $str =~ /^\s*WHERE\s+(.*)/i ) + { + $str = $1; + } + else + { + croak "Couldn't find WHERE clause in '$str'"; + } + my ($neg) = $str =~ s/^\s*(NOT)\s+//is; + my $opexp = '=|<>|<=|>=|<|>|LIKE|CLIKE|IS'; + my ( $val1, $op, $val2 ) = $str =~ /^(.+?)\s*($opexp)\s*(.+)\s*$/iso; + croak "Couldn't parse WHERE expression '$str'" unless ( defined $val1 and defined $op and defined $val2 ); + return { + arg1 => $self->parse_value($val1), + arg2 => $self->parse_value($val2), + op => $op, + neg => $neg, + }; +} + +##################################################################### +# EXECUTE +##################################################################### +sub execute +{ + my ( $self, $data, $params ) = @_; + my $num_placeholders = $self->params; + my $num_params = scalar @$params || 0; + croak "Number of params '$num_params' does not match number of placeholders '$num_placeholders'" + unless ( $num_placeholders == $num_params ); + if ( scalar @$params ) + { + for my $i ( 0 .. $#{ $self->{values} } ) + { + if ( $self->{values}->[$i]->{type} eq 'placeholder' ) + { + $self->{values}->[$i]->{value} = shift @$params; + } + } + if ( $self->{where_clause} ) + { + if ( $self->{where_clause}->{arg1}->{type} eq 'placeholder' ) + { + $self->{where_clause}->{arg1}->{value} = shift @$params; + } + if ( $self->{where_clause}->{arg2}->{type} eq 'placeholder' ) + { + $self->{where_clause}->{arg2}->{value} = shift @$params; + } + } + } + my $command = $self->{command}; + ( $self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'}, $self->{'data'}, ) = $self->$command( $data, $params ); + $self->{NAME} ||= $self->{column_names}; + return $self->{'NUM_OF_ROWS'} || '0E0'; +} + +my $enoentstr = "Cannot open .*\(" . Errno::ENOENT . "\)"; +my $enoentrx = qr/$enoentstr/; + +sub DROP ($$$) +{ + my ( $self, $data, $params ) = @_; + + my $table; + my @err; + eval { + local $SIG{__WARN__} = sub { push @err, @_ }; + ($table) = $self->open_tables( $data, 0, 1 ); + }; + if ( $self->{ignore_missing_table} and ( $@ or @err ) and grep { $_ =~ $enoentrx } ( @err, $@ ) ) + { + $@ = ''; + return ( -1, 0 ); + } + + croak( $@ || $err[0] ) if ( $@ || @err ); + return ( -1, 0 ) unless $table; + + $table->drop($data); + ( -1, 0 ); +} + +sub CREATE ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 1, 1 ); + $table->push_names( $data, $self->{column_names} ); + ( 0, 0 ); +} + +sub INSERT ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 1 ); + $self->verify_columns($table); + my $all_columns = $table->{col_names}; + $table->seek( $data, 0, 2 ) unless ( $table->can('insert_one_row') ); + my ($array) = []; + my ( $val, $col, $i ); + $self->{column_names} = $table->col_names() unless ( $self->{column_names} ); + my $cNum = scalar( @{ $self->{column_names} } ) if ( $self->{column_names} ); + my $param_num = 0; + + $cNum or + croak "Bad col names in INSERT"; + + my $maxCol = $#$all_columns; + + for ( $i = 0; $i < $cNum; $i++ ) + { + $col = $self->{column_names}->[$i]; + $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i); + } + + # Extend row to put values in ALL fields + $#$array < $maxCol and $array->[$maxCol] = undef; + + $table->can('insert_new_row') ? $table->insert_new_row( $data, $array ) : $table->push_row( $data, $array ); + + return ( 1, 0 ); +} + +sub DELETE ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 1 ); + $self->verify_columns($table); + my ($affected) = 0; + my ( @rows, $array ); + my $can_dor = $table->can('delete_one_row'); + while ( $array = $table->fetch_row($data) ) + { + if ( $self->eval_where( $table, $array ) ) + { + ++$affected; + if ( $self->{fetched_from_key} ) + { + $array = $self->{fetched_value}; + $table->delete_one_row( $data, $array ); + return ( $affected, 0 ); + } + push( @rows, $array ) if ($can_dor); + } + else + { + push( @rows, $array ) unless ($can_dor); + } + } + if ($can_dor) + { + foreach $array (@rows) + { + $table->delete_one_row( $data, $array ); + } + } + else + { + $table->seek( $data, 0, 0 ); + foreach $array (@rows) + { + $table->push_row( $data, $array ); + } + $table->truncate($data); + } + return ( $affected, 0 ); +} + +sub _anycmp($$;$) +{ + my ( $a, $b, $case_fold ) = @_; + + if ( !defined($a) || !defined($b) ) + { + return defined($a) - defined($b); + } + elsif ( DBI::looks_like_number($a) && DBI::looks_like_number($b) ) + { + return $a <=> $b; + } + else + { + return $case_fold ? lc($a) cmp lc($b) || $a cmp $b : $a cmp $b; + } +} + +sub SELECT ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 0 ); + $self->verify_columns($table); + my $tname = $self->{table_name}; + my ($affected) = 0; + my ( @rows, %cols, $array, $val, $col, $i ); + while ( $array = $table->fetch_row($data) ) + { + if ( $self->eval_where( $table, $array ) ) + { + $array = $self->{fetched_value} if ( $self->{fetched_from_key} ); + unless ( keys %cols ) + { + my $col_nums = $self->column_nums($table); + %cols = reverse %{$col_nums}; + } + + my $rowhash; + for ( sort keys %cols ) + { + $rowhash->{ $cols{$_} } = $array->[$_]; + } + my @newarray; + for ( $i = 0; $i < @{ $self->{column_names} }; $i++ ) + { + $col = $self->{column_names}->[$i]; + push @newarray, $rowhash->{$col}; + } + push( @rows, \@newarray ); + return ( scalar(@rows), scalar @{ $self->{column_names} }, \@rows ) + if ( $self->{fetched_from_key} ); + } + } + if ( $self->{order_clause} ) + { + my ( $sort_col, $desc ) = each %{ $self->{order_clause} }; + my @sortCols = ( $self->column_nums( $table, $sort_col, 1 ) ); + $sortCols[1] = uc $desc eq 'DESC' ? 1 : 0; + + @rows = sort { + my ( $result, $colNum, $desc ); + my $i = 0; + do + { + $colNum = $sortCols[ $i++ ]; + $desc = $sortCols[ $i++ ]; + $result = _anycmp( $a->[$colNum], $b->[$colNum] ); + $result = -$result if ($desc); + } while ( !$result && $i < @sortCols ); + $result; + } @rows; + } + ( scalar(@rows), scalar @{ $self->{column_names} }, \@rows ); +} + +sub UPDATE ($$$) +{ + my ( $self, $data, $params ) = @_; + my $table = $self->open_tables( $data, 0, 1 ); + $self->verify_columns($table); + return undef unless $table; + my $affected = 0; + my $can_usr = $table->can('update_specific_row'); + my $can_uor = $table->can('update_one_row'); + my $can_rwu = $can_usr || $can_uor; + my ( @rows, $array, $f_array, $val, $col, $i ); + + while ( $array = $table->fetch_row($data) ) + { + if ( $self->eval_where( $table, $array ) ) + { + $array = $self->{fetched_value} if ( $self->{fetched_from_key} and $can_rwu ); + my $orig_ary = clone($array) if ($can_usr); + for ( $i = 0; $i < @{ $self->{column_names} }; $i++ ) + { + $col = $self->{column_names}->[$i]; + $array->[ $self->column_nums( $table, $col ) ] = $self->row_values($i); + } + $affected++; + if ( $self->{fetched_value} ) + { + if ($can_usr) + { + $table->update_specific_row( $data, $array, $orig_ary ); + } + elsif ($can_uor) + { + $table->update_one_row( $data, $array ); + } + return ( $affected, 0 ); + } + push( @rows, $can_usr ? [ $array, $orig_ary ] : $array ); + } + else + { + push( @rows, $array ) unless ($can_rwu); + } + } + if ($can_rwu) + { + foreach my $array (@rows) + { + if ($can_usr) + { + $table->update_specific_row( $data, @$array ); + } + elsif ($can_uor) + { + $table->update_one_row( $data, $array ); + } + } + } + else + { + $table->seek( $data, 0, 0 ); + foreach my $array (@rows) + { + $table->push_row( $data, $array ); + } + $table->truncate($data); + } + + return ( $affected, 0 ); +} + +sub verify_columns +{ + my ( $self, $table ) = @_; + my @cols = @{ $self->{column_names} }; + if ( $self->{where_clause} ) + { + if ( my $col = $self->{where_clause}->{arg1} ) + { + push @cols, $col->{value} if $col->{type} eq 'column'; + } + if ( my $col = $self->{where_clause}->{arg2} ) + { + push @cols, $col->{value} if $col->{type} eq 'column'; + } + } + for (@cols) + { + $self->column_nums( $table, $_ ); + } +} + +sub column_nums +{ + my ( $self, $table, $stmt_col_name, $find_in_stmt ) = @_; + my %dbd_nums = %{ $table->col_nums() }; + my @dbd_cols = @{ $table->col_names() }; + my %stmt_nums; + if ( $stmt_col_name and !$find_in_stmt ) + { + while ( my ( $k, $v ) = each %dbd_nums ) + { + return $v if uc $k eq uc $stmt_col_name; + } + croak "No such column '$stmt_col_name'"; + } + if ( $stmt_col_name and $find_in_stmt ) + { + for my $i ( 0 .. @{ $self->{column_names} } ) + { + return $i if uc $stmt_col_name eq uc $self->{column_names}->[$i]; + } + croak "No such column '$stmt_col_name'"; + } + for my $i ( 0 .. $#dbd_cols ) + { + for my $stmt_col ( @{ $self->{column_names} } ) + { + $stmt_nums{$stmt_col} = $i if uc $dbd_cols[$i] eq uc $stmt_col; + } + } + return \%stmt_nums; +} + +sub eval_where +{ + my ( $self, $table, $rowary ) = @_; + my $where = $self->{"where_clause"} || return 1; + my $col_nums = $table->col_nums(); + my %cols = reverse %{$col_nums}; + my $rowhash; + for ( sort keys %cols ) + { + $rowhash->{ uc $cols{$_} } = $rowary->[$_]; + } + return $self->process_predicate( $where, $table, $rowhash ); +} + +sub process_predicate +{ + my ( $self, $pred, $table, $rowhash ) = @_; + my $val1 = $pred->{arg1}; + if ( $val1->{type} eq 'column' ) + { + $val1 = $rowhash->{ uc $val1->{value} }; + } + else + { + $val1 = $val1->{value}; + } + my $val2 = $pred->{arg2}; + if ( $val2->{type} eq 'column' ) + { + $val2 = $rowhash->{ uc $val2->{value} }; + } + else + { + $val2 = $val2->{value}; + } + my $op = $pred->{op}; + my $neg = $pred->{neg}; + if ( $op eq '=' and !$neg and $table->can('fetch_one_row') ) + { + my $key_col = $table->fetch_one_row( 1, 1 ); + if ( $pred->{arg1}->{value} =~ /^$key_col$/i ) + { + $self->{fetched_from_key} = 1; + $self->{fetched_value} = $table->fetch_one_row( 0, $pred->{arg2}->{value} ); + return 1; + } + } + my $match = $self->is_matched( $val1, $op, $val2 ) || 0; + if ($neg) { $match = $match ? 0 : 1; } + return $match; +} + +sub is_matched +{ + my ( $self, $val1, $op, $val2 ) = @_; + if ( $op eq 'IS' ) + { + return 1 if ( !defined $val1 or $val1 eq '' ); + return 0; + } + $val1 = '' unless ( defined $val1 ); + $val2 = '' unless ( defined $val2 ); + if ( $op =~ /LIKE|CLIKE/i ) + { + $val2 = quotemeta($val2); + $val2 =~ s/\\%/.*/g; + $val2 =~ s/_/./g; + } + if ( $op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; } + if ( $op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; } + if ( DBI::looks_like_number($val1) && DBI::looks_like_number($val2) ) + { + if ( $op eq '<' ) { return $val1 < $val2; } + if ( $op eq '>' ) { return $val1 > $val2; } + if ( $op eq '=' ) { return $val1 == $val2; } + if ( $op eq '<>' ) { return $val1 != $val2; } + if ( $op eq '<=' ) { return $val1 <= $val2; } + if ( $op eq '>=' ) { return $val1 >= $val2; } + } + else + { + if ( $op eq '<' ) { return $val1 lt $val2; } + if ( $op eq '>' ) { return $val1 gt $val2; } + if ( $op eq '=' ) { return $val1 eq $val2; } + if ( $op eq '<>' ) { return $val1 ne $val2; } + if ( $op eq '<=' ) { return $val1 ge $val2; } + if ( $op eq '>=' ) { return $val1 le $val2; } + } +} + +sub params +{ + my ( $self, $val_num ) = @_; + if ( !$self->{"params"} ) { return 0; } + if ( defined $val_num ) + { + return $self->{"params"}->[$val_num]; + } + + return wantarray ? @{ $self->{"params"} } : scalar @{ $self->{"params"} }; +} + +sub open_tables +{ + my ( $self, $data, $createMode, $lockMode ) = @_; + my $table_name = $self->{table_name}; + my $table; + eval { $table = $self->open_table( $data, $table_name, $createMode, $lockMode ) }; + if ($@) + { + chomp $@; + croak $@; + } + croak "Couldn't open table '$table_name'" unless $table; + if ( !$self->{column_names} or $self->{column_names}->[0] eq '*' ) + { + $self->{column_names} = $table->col_names(); + } + return $table; +} + +sub row_values +{ + my ( $self, $val_num ) = @_; + if ( !$self->{"values"} ) { return 0; } + if ( defined $val_num ) + { + return $self->{"values"}->[$val_num]->{value}; + } + if (wantarray) + { + return map { $_->{"value"} } @{ $self->{"values"} }; + } + else + { + return scalar @{ $self->{"values"} }; + } +} + +sub column_names +{ + my ($self) = @_; + my @col_names; + if ( $self->{column_names} and $self->{column_names}->[0] ne '*' ) + { + @col_names = @{ $self->{column_names} }; + } + return @col_names; +} + +############################### +package DBI::SQL::Nano::Table_; +############################### + +use Carp qw(croak); + +sub new ($$) +{ + my ( $proto, $attr ) = @_; + my ($self) = {%$attr}; + + defined( $self->{col_names} ) and "ARRAY" eq ref( $self->{col_names} ) + or croak("attribute 'col_names' must be defined as an array"); + exists( $self->{col_nums} ) or $self->{col_nums} = _map_colnums( $self->{col_names} ); + defined( $self->{col_nums} ) and "HASH" eq ref( $self->{col_nums} ) + or croak("attribute 'col_nums' must be defined as a hash"); + + bless( $self, ( ref($proto) || $proto ) ); + return $self; +} + +sub _map_colnums +{ + my $col_names = $_[0]; + my %col_nums; + for my $i ( 0 .. $#$col_names ) + { + next unless $col_names->[$i]; + $col_nums{ $col_names->[$i] } = $i; + } + return \%col_nums; +} + +sub row() { return $_[0]->{row}; } +sub column($) { return $_[0]->{row}->[ $_[0]->column_num( $_[1] ) ]; } +sub column_num($) { $_[0]->{col_nums}->{ $_[1] }; } +sub col_nums() { $_[0]->{col_nums} } +sub col_names() { $_[0]->{col_names}; } + +sub drop ($$) { croak "Abstract method " . ref( $_[0] ) . "::drop called" } +sub fetch_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::fetch_row called" } +sub push_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_row called" } +sub push_names ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_names called" } +sub truncate ($$) { croak "Abstract method " . ref( $_[0] ) . "::truncate called" } +sub seek ($$$$) { croak "Abstract method " . ref( $_[0] ) . "::seek called" } + +1; +__END__ + +#line 1014 + diff --git a/apps/lib/DBI/Util/_accessor.pm b/apps/lib/DBI/Util/_accessor.pm new file mode 100644 index 0000000..96ed4fe --- /dev/null +++ b/apps/lib/DBI/Util/_accessor.pm @@ -0,0 +1,66 @@ +#line 1 "DBI/Util/_accessor.pm" +package DBI::Util::_accessor; +use strict; +use Carp; +our $VERSION = "0.009479"; + +# inspired by Class::Accessor::Fast + +sub new { + my($proto, $fields) = @_; + my($class) = ref $proto || $proto; + $fields ||= {}; + + my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields; + carp "$class doesn't have accessors for fields: @dubious" if @dubious; + + # make a (shallow) copy of $fields. + bless {%$fields}, $class; +} + +sub mk_accessors { + my($self, @fields) = @_; + $self->mk_accessors_using('make_accessor', @fields); +} + +sub mk_accessors_using { + my($self, $maker, @fields) = @_; + my $class = ref $self || $self; + + # So we don't have to do lots of lookups inside the loop. + $maker = $self->can($maker) unless ref $maker; + + no strict 'refs'; + foreach my $field (@fields) { + my $accessor = $self->$maker($field); + *{$class."\:\:$field"} = $accessor + unless defined &{$class."\:\:$field"}; + } + #my $hash_ref = \%{$class."\:\:_accessors_hash}; + #$hash_ref->{$_}++ for @fields; + # XXX also copy down _accessors_hash of base class(es) + # so one in this class is complete + return; +} + +sub make_accessor { + my($class, $field) = @_; + return sub { + my $self = shift; + return $self->{$field} unless @_; + croak "Too many arguments to $field" if @_ > 1; + return $self->{$field} = shift; + }; +} + +sub make_accessor_autoviv_hashref { + my($class, $field) = @_; + return sub { + my $self = shift; + return $self->{$field} ||= {} unless @_; + croak "Too many arguments to $field" if @_ > 1; + return $self->{$field} = shift; + }; +} + +1; diff --git a/lib/Digest/SHA/PurePerl.pm b/apps/lib/Digest/SHA/PurePerl.pm similarity index 64% rename from lib/Digest/SHA/PurePerl.pm rename to apps/lib/Digest/SHA/PurePerl.pm index 6b63af5..602cc74 100644 --- a/lib/Digest/SHA/PurePerl.pm +++ b/apps/lib/Digest/SHA/PurePerl.pm @@ -1,3 +1,4 @@ +#line 1 "Digest/SHA/PurePerl.pm" package Digest::SHA::PurePerl; require 5.003000; @@ -1027,560 +1028,4 @@ sub load { 1; __END__ -=head1 NAME - -Digest::SHA::PurePerl - Perl implementation of SHA-1/224/256/384/512 - -=head1 SYNOPSIS - -In programs: - - # Functional interface - - use Digest::SHA::PurePerl qw(sha1 sha1_hex sha1_base64 ...); - - $digest = sha1($data); - $digest = sha1_hex($data); - $digest = sha1_base64($data); - - $digest = sha256($data); - $digest = sha384_hex($data); - $digest = sha512_base64($data); - - # Object-oriented - - use Digest::SHA::PurePerl; - - $sha = Digest::SHA::PurePerl->new($alg); - - $sha->add($data); # feed data into stream - - $sha->addfile(*F); - $sha->addfile($filename); - - $sha->add_bits($bits); - $sha->add_bits($data, $nbits); - - $sha_copy = $sha->clone; # make copy of digest object - $state = $sha->getstate; # save current state to string - $sha->putstate($state); # restore previous $state - - $digest = $sha->digest; # compute digest - $digest = $sha->hexdigest; - $digest = $sha->b64digest; - -From the command line: - - $ shasumpp files - - $ shasumpp --help - -=head1 SYNOPSIS (HMAC-SHA) - - # Functional interface only - - use Digest::SHA::PurePerl qw(hmac_sha1 hmac_sha1_hex ...); - - $digest = hmac_sha1($data, $key); - $digest = hmac_sha224_hex($data, $key); - $digest = hmac_sha256_base64($data, $key); - -=head1 ABSTRACT - -Digest::SHA::PurePerl is a complete implementation of the NIST Secure -Hash Standard. It gives Perl programmers a convenient way to calculate -SHA-1, SHA-224, SHA-256, SHA-384, SHA-512, SHA-512/224, and SHA-512/256 -message digests. The module can handle all types of input, including -partial-byte data. - -=head1 DESCRIPTION - -Digest::SHA::PurePerl is written entirely in Perl. If your platform -has a C compiler, you should install the functionally equivalent -(but much faster) L module. - -The programming interface is easy to use: it's the same one found -in CPAN's L module. So, if your applications currently -use L and you'd prefer the stronger security of SHA, -it's a simple matter to convert them. - -The interface provides two ways to calculate digests: all-at-once, -or in stages. To illustrate, the following short program computes -the SHA-256 digest of "hello world" using each approach: - - use Digest::SHA::PurePerl qw(sha256_hex); - - $data = "hello world"; - @frags = split(//, $data); - - # all-at-once (Functional style) - $digest1 = sha256_hex($data); - - # in-stages (OOP style) - $state = Digest::SHA::PurePerl->new(256); - for (@frags) { $state->add($_) } - $digest2 = $state->hexdigest; - - print $digest1 eq $digest2 ? - "whew!\n" : "oops!\n"; - -To calculate the digest of an n-bit message where I is not a -multiple of 8, use the I method. For example, consider -the 446-bit message consisting of the bit-string "110" repeated -148 times, followed by "11". Here's how to display its SHA-1 -digest: - - use Digest::SHA::PurePerl; - $bits = "110" x 148 . "11"; - $sha = Digest::SHA::PurePerl->new(1)->add_bits($bits); - print $sha->hexdigest, "\n"; - -Note that for larger bit-strings, it's more efficient to use the -two-argument version I, where I<$data> is -in the customary packed binary format used for Perl strings. - -The module also lets you save intermediate SHA states to a string. The -I method generates portable, human-readable text describing -the current state of computation. You can subsequently restore that -state with I to resume where the calculation left off. - -To see what a state description looks like, just run the following: - - use Digest::SHA::PurePerl; - print Digest::SHA::PurePerl->new->add("Shaw" x 1962)->getstate; - -As an added convenience, the Digest::SHA::PurePerl module offers -routines to calculate keyed hashes using the HMAC-SHA-1/224/256/384/512 -algorithms. These services exist in functional form only, and -mimic the style and behavior of the I, I, and -I functions. - - # Test vector from draft-ietf-ipsec-ciph-sha-256-01.txt - - use Digest::SHA::PurePerl qw(hmac_sha256_hex); - print hmac_sha256_hex("Hi There", chr(0x0b) x 32), "\n"; - -=head1 UNICODE AND SIDE EFFECTS - -Perl supports Unicode strings as of version 5.6. Such strings may -contain wide characters, namely, characters whose ordinal values are -greater than 255. This can cause problems for digest algorithms such -as SHA that are specified to operate on sequences of bytes. - -The rule by which Digest::SHA::PurePerl handles a Unicode string is easy -to state, but potentially confusing to grasp: the string is interpreted -as a sequence of byte values, where each byte value is equal to the -ordinal value (viz. code point) of its corresponding Unicode character. -That way, the Unicode string 'abc' has exactly the same digest value as -the ordinary string 'abc'. - -Since a wide character does not fit into a byte, the Digest::SHA::PurePerl -routines croak if they encounter one. Whereas if a Unicode string -contains no wide characters, the module accepts it quite happily. -The following code illustrates the two cases: - - $str1 = pack('U*', (0..255)); - print sha1_hex($str1); # ok - - $str2 = pack('U*', (0..256)); - print sha1_hex($str2); # croaks - -Be aware that the digest routines silently convert UTF-8 input into its -equivalent byte sequence in the native encoding (cf. utf8::downgrade). -This side effect influences only the way Perl stores the data internally, -but otherwise leaves the actual value of the data intact. - -=head1 NIST STATEMENT ON SHA-1 - -NIST acknowledges that the work of Prof. Xiaoyun Wang constitutes a -practical collision attack on SHA-1. Therefore, NIST encourages the -rapid adoption of the SHA-2 hash functions (e.g. SHA-256) for applications -requiring strong collision resistance, such as digital signatures. - -ref. L - -=head1 PADDING OF BASE64 DIGESTS - -By convention, CPAN Digest modules do B pad their Base64 output. -Problems can occur when feeding such digests to other software that -expects properly padded Base64 encodings. - -For the time being, any necessary padding must be done by the user. -Fortunately, this is a simple operation: if the length of a Base64-encoded -digest isn't a multiple of 4, simply append "=" characters to the end -of the digest until it is: - - while (length($b64_digest) % 4) { - $b64_digest .= '='; - } - -To illustrate, I is computed to be - - ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0 - -which has a length of 43. So, the properly padded version is - - ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0= - -=head1 EXPORT - -None by default. - -=head1 EXPORTABLE FUNCTIONS - -Provided your Perl installation supports 64-bit integers, all of -these functions will be available for use. Otherwise, you won't -be able to perform the SHA-384 and SHA-512 transforms, both of -which require 64-bit operations. - -I - -=over 4 - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -Logically joins the arguments into a single string, and returns -its SHA-1/224/256/384/512 digest encoded as a binary string. - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -Logically joins the arguments into a single string, and returns -its SHA-1/224/256/384/512 digest encoded as a hexadecimal string. - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -Logically joins the arguments into a single string, and returns -its SHA-1/224/256/384/512 digest encoded as a Base64 string. - -It's important to note that the resulting string does B contain -the padding characters typical of Base64 encodings. This omission is -deliberate, and is done to maintain compatibility with the family of -CPAN Digest modules. See L for details. - -=back - -I - -=over 4 - -=item B - -Returns a new Digest::SHA::PurePerl object. Allowed values for -I<$alg> are 1, 224, 256, 384, 512, 512224, or 512256. It's also -possible to use common string representations of the algorithm -(e.g. "sha256", "SHA-384"). If the argument is missing, SHA-1 will -be used by default. - -Invoking I as an instance method will reset the object to the -initial state associated with I<$alg>. If the argument is missing, -the object will continue using the same algorithm that was selected -at creation. - -=item B - -This method has exactly the same effect as I. In fact, -I is just an alias for I. - -=item B - -Returns the number of digest bits for this object. The values are -160, 224, 256, 384, 512, 224, and 256 for SHA-1, SHA-224, SHA-256, -SHA-384, SHA-512, SHA-512/224, and SHA-512/256, respectively. - -=item B - -Returns the digest algorithm for this object. The values are 1, -224, 256, 384, 512, 512224, and 512256 for SHA-1, SHA-224, SHA-256, -SHA-384, SHA-512, SHA-512/224, and SHA-512/256, respectively. - -=item B - -Returns a duplicate copy of the object. - -=item B - -Logically joins the arguments into a single string, and uses it to -update the current digest state. In other words, the following -statements have the same effect: - - $sha->add("a"); $sha->add("b"); $sha->add("c"); - $sha->add("a")->add("b")->add("c"); - $sha->add("a", "b", "c"); - $sha->add("abc"); - -The return value is the updated object itself. - -=item B - -=item B - -Updates the current digest state by appending bits to it. The -return value is the updated object itself. - -The first form causes the most-significant I<$nbits> of I<$data> -to be appended to the stream. The I<$data> argument is in the -customary binary format used for Perl strings. - -The second form takes an ASCII string of "0" and "1" characters as -its argument. It's equivalent to - - $sha->add_bits(pack("B*", $bits), length($bits)); - -So, the following two statements do the same thing: - - $sha->add_bits("111100001010"); - $sha->add_bits("\xF0\xA0", 12); - -=item B - -Reads from I until EOF, and appends that data to the current -state. The return value is the updated object itself. - -=item B - -Reads the contents of I<$filename>, and appends that data to the current -state. The return value is the updated object itself. - -By default, I<$filename> is simply opened and read; no special modes -or I/O disciplines are used. To change this, set the optional I<$mode> -argument to one of the following values: - - "b" read file in binary mode - - "U" use universal newlines - - "0" use BITS mode - -The "U" mode is modeled on Python's "Universal Newlines" concept, whereby -DOS and Mac OS line terminators are converted internally to UNIX newlines -before processing. This ensures consistent digest values when working -simultaneously across multiple file systems. B, namely those passing Perl's I<-T> test; binary files -are processed with no translation whatsoever. - -The BITS mode ("0") interprets the contents of I<$filename> as a logical -stream of bits, where each ASCII '0' or '1' character represents a 0 or -1 bit, respectively. All other characters are ignored. This provides -a convenient way to calculate the digest values of partial-byte data -by using files, rather than having to write separate programs employing -the I method. - -=item B - -Returns a string containing a portable, human-readable representation -of the current SHA state. - -=item B - -Returns a Digest::SHA object representing the SHA state contained -in I<$str>. The format of I<$str> matches the format of the output -produced by method I. If called as a class method, a new -object is created; if called as an instance method, the object is reset -to the state contained in I<$str>. - -=item B - -Writes the output of I to I<$filename>. If the argument is -missing, or equal to the empty string, the state information will be -written to STDOUT. - -=item B - -Returns a Digest::SHA object that results from calling I on -the contents of I<$filename>. If the argument is missing, or equal to -the empty string, the state information will be read from STDIN. - -=item B - -Returns the digest encoded as a binary string. - -Note that the I method is a read-once operation. Once it -has been performed, the Digest::SHA::PurePerl object is automatically -reset in preparation for calculating another digest value. Call -I<$sha-Eclone-Edigest> if it's necessary to preserve the -original digest state. - -=item B - -Returns the digest encoded as a hexadecimal string. - -Like I, this method is a read-once operation. Call -I<$sha-Eclone-Ehexdigest> if it's necessary to preserve -the original digest state. - -=item B - -Returns the digest encoded as a Base64 string. - -Like I, this method is a read-once operation. Call -I<$sha-Eclone-Eb64digest> if it's necessary to preserve -the original digest state. - -It's important to note that the resulting string does B contain -the padding characters typical of Base64 encodings. This omission is -deliberate, and is done to maintain compatibility with the family of -CPAN Digest modules. See L for details. - -=back - -I - -=over 4 - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>, -with the result encoded as a binary string. Multiple I<$data> -arguments are allowed, provided that I<$key> is the last argument -in the list. - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>, -with the result encoded as a hexadecimal string. Multiple I<$data> -arguments are allowed, provided that I<$key> is the last argument -in the list. - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -=item B - -Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>, -with the result encoded as a Base64 string. Multiple I<$data> -arguments are allowed, provided that I<$key> is the last argument -in the list. - -It's important to note that the resulting string does B contain -the padding characters typical of Base64 encodings. This omission is -deliberate, and is done to maintain compatibility with the family of -CPAN Digest modules. See L for details. - -=back - -=head1 SEE ALSO - -L, L - -The Secure Hash Standard (Draft FIPS PUB 180-4) can be found at: - -L - -The Keyed-Hash Message Authentication Code (HMAC): - -L - -=head1 AUTHOR - - Mark Shelor - -=head1 ACKNOWLEDGMENTS - -The author is particularly grateful to - - Gisle Aas - Sean Burke - Chris Carey - Alexandr Ciornii - Chris David - Jim Doble - Thomas Drugeon - Julius Duque - Jeffrey Friedl - Robert Gilmour - Brian Gladman - Adam Kennedy - Mark Lawrence - Andy Lester - Alex Muntada - Steve Peters - Chris Skiscim - Martin Thurn - Gunnar Wolf - Adam Woodbury - -"A candle in the bar was lighting up the dirty windows, on one of -which was a notice, in white enamel letters, telling customers they -could bring their own food: ON PEUT APPORTER SON MANGER, from which -the M and the last R were missing." -- Maigret's War of Nerves - -=head1 COPYRIGHT AND LICENSE - -Copyright (C) 2003-2018 Mark Shelor - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -L - -=cut +#line 1587 diff --git a/apps/lib/Fh.pm b/apps/lib/Fh.pm new file mode 100644 index 0000000..98c2d4c --- /dev/null +++ b/apps/lib/Fh.pm @@ -0,0 +1,11 @@ +#line 1 "Fh.pm" +# back compatibility package for any code explicitly checking +# that the filehandle object is a Fh +package Fh; + +use strict; +use warnings; + +$Fh::VERSION = '4.35'; + +1; diff --git a/apps/lib/HTML/Entities.pm b/apps/lib/HTML/Entities.pm new file mode 100644 index 0000000..297fc33 --- /dev/null +++ b/apps/lib/HTML/Entities.pm @@ -0,0 +1,353 @@ +#line 1 "HTML/Entities.pm" +package HTML::Entities; + + + +#line 137 + +use strict; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); +use vars qw(%entity2char %char2entity); + +require 5.004; +require Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw(encode_entities decode_entities _decode_entities); +@EXPORT_OK = qw(%entity2char %char2entity encode_entities_numeric); + +$VERSION = "3.69"; +sub Version { $VERSION; } + +require HTML::Parser; # for fast XS implemented decode_entities + + +%entity2char = ( + # Some normal chars that have special meaning in SGML context + amp => '&', # ampersand +'gt' => '>', # greater than +'lt' => '<', # less than + quot => '"', # double quote + apos => "'", # single quote + + # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML + AElig => chr(198), # capital AE diphthong (ligature) + Aacute => chr(193), # capital A, acute accent + Acirc => chr(194), # capital A, circumflex accent + Agrave => chr(192), # capital A, grave accent + Aring => chr(197), # capital A, ring + Atilde => chr(195), # capital A, tilde + Auml => chr(196), # capital A, dieresis or umlaut mark + Ccedil => chr(199), # capital C, cedilla + ETH => chr(208), # capital Eth, Icelandic + Eacute => chr(201), # capital E, acute accent + Ecirc => chr(202), # capital E, circumflex accent + Egrave => chr(200), # capital E, grave accent + Euml => chr(203), # capital E, dieresis or umlaut mark + Iacute => chr(205), # capital I, acute accent + Icirc => chr(206), # capital I, circumflex accent + Igrave => chr(204), # capital I, grave accent + Iuml => chr(207), # capital I, dieresis or umlaut mark + Ntilde => chr(209), # capital N, tilde + Oacute => chr(211), # capital O, acute accent + Ocirc => chr(212), # capital O, circumflex accent + Ograve => chr(210), # capital O, grave accent + Oslash => chr(216), # capital O, slash + Otilde => chr(213), # capital O, tilde + Ouml => chr(214), # capital O, dieresis or umlaut mark + THORN => chr(222), # capital THORN, Icelandic + Uacute => chr(218), # capital U, acute accent + Ucirc => chr(219), # capital U, circumflex accent + Ugrave => chr(217), # capital U, grave accent + Uuml => chr(220), # capital U, dieresis or umlaut mark + Yacute => chr(221), # capital Y, acute accent + aacute => chr(225), # small a, acute accent + acirc => chr(226), # small a, circumflex accent + aelig => chr(230), # small ae diphthong (ligature) + agrave => chr(224), # small a, grave accent + aring => chr(229), # small a, ring + atilde => chr(227), # small a, tilde + auml => chr(228), # small a, dieresis or umlaut mark + ccedil => chr(231), # small c, cedilla + eacute => chr(233), # small e, acute accent + ecirc => chr(234), # small e, circumflex accent + egrave => chr(232), # small e, grave accent + eth => chr(240), # small eth, Icelandic + euml => chr(235), # small e, dieresis or umlaut mark + iacute => chr(237), # small i, acute accent + icirc => chr(238), # small i, circumflex accent + igrave => chr(236), # small i, grave accent + iuml => chr(239), # small i, dieresis or umlaut mark + ntilde => chr(241), # small n, tilde + oacute => chr(243), # small o, acute accent + ocirc => chr(244), # small o, circumflex accent + ograve => chr(242), # small o, grave accent + oslash => chr(248), # small o, slash + otilde => chr(245), # small o, tilde + ouml => chr(246), # small o, dieresis or umlaut mark + szlig => chr(223), # small sharp s, German (sz ligature) + thorn => chr(254), # small thorn, Icelandic + uacute => chr(250), # small u, acute accent + ucirc => chr(251), # small u, circumflex accent + ugrave => chr(249), # small u, grave accent + uuml => chr(252), # small u, dieresis or umlaut mark + yacute => chr(253), # small y, acute accent + yuml => chr(255), # small y, dieresis or umlaut mark + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => chr(169), # copyright sign + reg => chr(174), # registered sign + nbsp => chr(160), # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => chr(161), + cent => chr(162), + pound => chr(163), + curren => chr(164), + yen => chr(165), + brvbar => chr(166), + sect => chr(167), + uml => chr(168), + ordf => chr(170), + laquo => chr(171), +'not' => chr(172), # not is a keyword in perl + shy => chr(173), + macr => chr(175), + deg => chr(176), + plusmn => chr(177), + sup1 => chr(185), + sup2 => chr(178), + sup3 => chr(179), + acute => chr(180), + micro => chr(181), + para => chr(182), + middot => chr(183), + cedil => chr(184), + ordm => chr(186), + raquo => chr(187), + frac14 => chr(188), + frac12 => chr(189), + frac34 => chr(190), + iquest => chr(191), +'times' => chr(215), # times is a keyword in perl + divide => chr(247), + + ( $] > 5.007 ? ( + 'OElig;' => chr(338), + 'oelig;' => chr(339), + 'Scaron;' => chr(352), + 'scaron;' => chr(353), + 'Yuml;' => chr(376), + 'fnof;' => chr(402), + 'circ;' => chr(710), + 'tilde;' => chr(732), + 'Alpha;' => chr(913), + 'Beta;' => chr(914), + 'Gamma;' => chr(915), + 'Delta;' => chr(916), + 'Epsilon;' => chr(917), + 'Zeta;' => chr(918), + 'Eta;' => chr(919), + 'Theta;' => chr(920), + 'Iota;' => chr(921), + 'Kappa;' => chr(922), + 'Lambda;' => chr(923), + 'Mu;' => chr(924), + 'Nu;' => chr(925), + 'Xi;' => chr(926), + 'Omicron;' => chr(927), + 'Pi;' => chr(928), + 'Rho;' => chr(929), + 'Sigma;' => chr(931), + 'Tau;' => chr(932), + 'Upsilon;' => chr(933), + 'Phi;' => chr(934), + 'Chi;' => chr(935), + 'Psi;' => chr(936), + 'Omega;' => chr(937), + 'alpha;' => chr(945), + 'beta;' => chr(946), + 'gamma;' => chr(947), + 'delta;' => chr(948), + 'epsilon;' => chr(949), + 'zeta;' => chr(950), + 'eta;' => chr(951), + 'theta;' => chr(952), + 'iota;' => chr(953), + 'kappa;' => chr(954), + 'lambda;' => chr(955), + 'mu;' => chr(956), + 'nu;' => chr(957), + 'xi;' => chr(958), + 'omicron;' => chr(959), + 'pi;' => chr(960), + 'rho;' => chr(961), + 'sigmaf;' => chr(962), + 'sigma;' => chr(963), + 'tau;' => chr(964), + 'upsilon;' => chr(965), + 'phi;' => chr(966), + 'chi;' => chr(967), + 'psi;' => chr(968), + 'omega;' => chr(969), + 'thetasym;' => chr(977), + 'upsih;' => chr(978), + 'piv;' => chr(982), + 'ensp;' => chr(8194), + 'emsp;' => chr(8195), + 'thinsp;' => chr(8201), + 'zwnj;' => chr(8204), + 'zwj;' => chr(8205), + 'lrm;' => chr(8206), + 'rlm;' => chr(8207), + 'ndash;' => chr(8211), + 'mdash;' => chr(8212), + 'lsquo;' => chr(8216), + 'rsquo;' => chr(8217), + 'sbquo;' => chr(8218), + 'ldquo;' => chr(8220), + 'rdquo;' => chr(8221), + 'bdquo;' => chr(8222), + 'dagger;' => chr(8224), + 'Dagger;' => chr(8225), + 'bull;' => chr(8226), + 'hellip;' => chr(8230), + 'permil;' => chr(8240), + 'prime;' => chr(8242), + 'Prime;' => chr(8243), + 'lsaquo;' => chr(8249), + 'rsaquo;' => chr(8250), + 'oline;' => chr(8254), + 'frasl;' => chr(8260), + 'euro;' => chr(8364), + 'image;' => chr(8465), + 'weierp;' => chr(8472), + 'real;' => chr(8476), + 'trade;' => chr(8482), + 'alefsym;' => chr(8501), + 'larr;' => chr(8592), + 'uarr;' => chr(8593), + 'rarr;' => chr(8594), + 'darr;' => chr(8595), + 'harr;' => chr(8596), + 'crarr;' => chr(8629), + 'lArr;' => chr(8656), + 'uArr;' => chr(8657), + 'rArr;' => chr(8658), + 'dArr;' => chr(8659), + 'hArr;' => chr(8660), + 'forall;' => chr(8704), + 'part;' => chr(8706), + 'exist;' => chr(8707), + 'empty;' => chr(8709), + 'nabla;' => chr(8711), + 'isin;' => chr(8712), + 'notin;' => chr(8713), + 'ni;' => chr(8715), + 'prod;' => chr(8719), + 'sum;' => chr(8721), + 'minus;' => chr(8722), + 'lowast;' => chr(8727), + 'radic;' => chr(8730), + 'prop;' => chr(8733), + 'infin;' => chr(8734), + 'ang;' => chr(8736), + 'and;' => chr(8743), + 'or;' => chr(8744), + 'cap;' => chr(8745), + 'cup;' => chr(8746), + 'int;' => chr(8747), + 'there4;' => chr(8756), + 'sim;' => chr(8764), + 'cong;' => chr(8773), + 'asymp;' => chr(8776), + 'ne;' => chr(8800), + 'equiv;' => chr(8801), + 'le;' => chr(8804), + 'ge;' => chr(8805), + 'sub;' => chr(8834), + 'sup;' => chr(8835), + 'nsub;' => chr(8836), + 'sube;' => chr(8838), + 'supe;' => chr(8839), + 'oplus;' => chr(8853), + 'otimes;' => chr(8855), + 'perp;' => chr(8869), + 'sdot;' => chr(8901), + 'lceil;' => chr(8968), + 'rceil;' => chr(8969), + 'lfloor;' => chr(8970), + 'rfloor;' => chr(8971), + 'lang;' => chr(9001), + 'rang;' => chr(9002), + 'loz;' => chr(9674), + 'spades;' => chr(9824), + 'clubs;' => chr(9827), + 'hearts;' => chr(9829), + 'diams;' => chr(9830), + ) : ()) +); + + +# Make the opposite mapping +while (my($entity, $char) = each(%entity2char)) { + $entity =~ s/;\z//; + $char2entity{$char} = "&$entity;"; +} +delete $char2entity{"'"}; # only one-way decoding + +# Fill in missing entities +for (0 .. 255) { + next if exists $char2entity{chr($_)}; + $char2entity{chr($_)} = "&#$_;"; +} + +my %subst; # compiled encoding regexps + +sub encode_entities +{ + return undef unless defined $_[0]; + my $ref; + if (defined wantarray) { + my $x = $_[0]; + $ref = \$x; # copy + } else { + $ref = \$_[0]; # modify in-place + } + if (defined $_[1] and length $_[1]) { + unless (exists $subst{$_[1]}) { + # Because we can't compile regex we fake it with a cached sub + my $chars = $_[1]; + $chars =~ s,(?', ''' and '"' + $$ref =~ s/([^\n\r\t !\#\$%\(-;=?-~])/$char2entity{$1} || num_entity($1)/ge; + } + $$ref; +} + +sub encode_entities_numeric { + local %char2entity; + return &encode_entities; # a goto &encode_entities wouldn't work +} + + +sub num_entity { + sprintf "&#x%X;", ord($_[0]); +} + +# Set up aliases +*encode = \&encode_entities; +*encode_numeric = \&encode_entities_numeric; +*encode_numerically = \&encode_entities_numeric; +*decode = \&decode_entities; + +1; diff --git a/apps/lib/HTML/Parser.pm b/apps/lib/HTML/Parser.pm new file mode 100644 index 0000000..f216ed9 --- /dev/null +++ b/apps/lib/HTML/Parser.pm @@ -0,0 +1,128 @@ +#line 1 "HTML/Parser.pm" +package HTML::Parser; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "3.72"; + +require HTML::Entities; + +require XSLoader; +XSLoader::load('HTML::Parser', $VERSION); + +sub new +{ + my $class = shift; + my $self = bless {}, $class; + return $self->init(@_); +} + + +sub init +{ + my $self = shift; + $self->_alloc_pstate; + + my %arg = @_; + my $api_version = delete $arg{api_version} || (@_ ? 3 : 2); + if ($api_version >= 4) { + require Carp; + Carp::croak("API version $api_version not supported " . + "by HTML::Parser $VERSION"); + } + + if ($api_version < 3) { + # Set up method callbacks compatible with HTML-Parser-2.xx + $self->handler(text => "text", "self,text,is_cdata"); + $self->handler(end => "end", "self,tagname,text"); + $self->handler(process => "process", "self,token0,text"); + $self->handler(start => "start", + "self,tagname,attr,attrseq,text"); + + $self->handler(comment => + sub { + my($self, $tokens) = @_; + for (@$tokens) { + $self->comment($_); + } + }, "self,tokens"); + + $self->handler(declaration => + sub { + my $self = shift; + $self->declaration(substr($_[0], 2, -1)); + }, "self,text"); + } + + if (my $h = delete $arg{handlers}) { + $h = {@$h} if ref($h) eq "ARRAY"; + while (my($event, $cb) = each %$h) { + $self->handler($event => @$cb); + } + } + + # In the end we try to assume plain attribute or handler + while (my($option, $val) = each %arg) { + if ($option =~ /^(\w+)_h$/) { + $self->handler($1 => @$val); + } + elsif ($option =~ /^(text|start|end|process|declaration|comment)$/) { + require Carp; + Carp::croak("Bad constructor option '$option'"); + } + else { + $self->$option($val); + } + } + + return $self; +} + + +sub parse_file +{ + my($self, $file) = @_; + my $opened; + if (!ref($file) && ref(\$file) ne "GLOB") { + # Assume $file is a filename + local(*F); + open(F, "<", $file) || return undef; + binmode(F); # should we? good for byte counts + $opened++; + $file = *F; + } + my $chunk = ''; + while (read($file, $chunk, 512)) { + $self->parse($chunk) || last; + } + close($file) if $opened; + $self->eof; +} + + +sub netscape_buggy_comment # legacy +{ + my $self = shift; + require Carp; + Carp::carp("netscape_buggy_comment() is deprecated. " . + "Please use the strict_comment() method instead"); + my $old = !$self->strict_comment; + $self->strict_comment(!shift) if @_; + return $old; +} + +# set up method stubs +sub text { } +*start = \&text; +*end = \&text; +*comment = \&text; +*declaration = \&text; +*process = \&text; + +1; + +__END__ + + +#line 1236 diff --git a/apps/lib/JSON/PP.pm b/apps/lib/JSON/PP.pm new file mode 100644 index 0000000..5534b14 --- /dev/null +++ b/apps/lib/JSON/PP.pm @@ -0,0 +1,1746 @@ +#line 1 "JSON/PP.pm" +package JSON::PP; + +# JSON-2.0 + +use 5.005; +use strict; + +use Exporter (); +BEGIN { @JSON::PP::ISA = ('Exporter') } + +use overload (); +use JSON::PP::Boolean; + +use Carp (); +#use Devel::Peek; + +$JSON::PP::VERSION = '4.02'; + +@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); + +# instead of hash-access, i tried index-access for speed. +# but this method is not faster than what i expected. so it will be changed. + +use constant P_ASCII => 0; +use constant P_LATIN1 => 1; +use constant P_UTF8 => 2; +use constant P_INDENT => 3; +use constant P_CANONICAL => 4; +use constant P_SPACE_BEFORE => 5; +use constant P_SPACE_AFTER => 6; +use constant P_ALLOW_NONREF => 7; +use constant P_SHRINK => 8; +use constant P_ALLOW_BLESSED => 9; +use constant P_CONVERT_BLESSED => 10; +use constant P_RELAXED => 11; + +use constant P_LOOSE => 12; +use constant P_ALLOW_BIGNUM => 13; +use constant P_ALLOW_BAREKEY => 14; +use constant P_ALLOW_SINGLEQUOTE => 15; +use constant P_ESCAPE_SLASH => 16; +use constant P_AS_NONBLESSED => 17; + +use constant P_ALLOW_UNKNOWN => 18; +use constant P_ALLOW_TAGS => 19; + +use constant OLD_PERL => $] < 5.008 ? 1 : 0; +use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0; + +BEGIN { + if (USE_B) { + require B; + } +} + +BEGIN { + my @xs_compati_bit_properties = qw( + latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink + allow_blessed convert_blessed relaxed allow_unknown + allow_tags + ); + my @pp_bit_properties = qw( + allow_singlequote allow_bignum loose + allow_barekey escape_slash as_nonblessed + ); + + # Perl version check, Unicode handling is enabled? + # Helper module sets @JSON::PP::_properties. + if ( OLD_PERL ) { + my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + } + + for my $name (@xs_compati_bit_properties, @pp_bit_properties) { + my $property_id = 'P_' . uc($name); + + eval qq/ + sub $name { + my \$enable = defined \$_[1] ? \$_[1] : 1; + + if (\$enable) { + \$_[0]->{PROPS}->[$property_id] = 1; + } + else { + \$_[0]->{PROPS}->[$property_id] = 0; + } + + \$_[0]; + } + + sub get_$name { + \$_[0]->{PROPS}->[$property_id] ? 1 : ''; + } + /; + } + +} + + + +# Functions + +my $JSON; # cache + +sub encode_json ($) { # encode + ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); +} + + +sub decode_json { # decode + ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); +} + +# Obsoleted + +sub to_json($) { + Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); +} + + +sub from_json($) { + Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); +} + + +# Methods + +sub new { + my $class = shift; + my $self = { + max_depth => 512, + max_size => 0, + indent_length => 3, + }; + + $self->{PROPS}[P_ALLOW_NONREF] = 1; + + bless $self, $class; +} + + +sub encode { + return $_[0]->PP_encode_json($_[1]); +} + + +sub decode { + return $_[0]->PP_decode_json($_[1], 0x00000000); +} + + +sub decode_prefix { + return $_[0]->PP_decode_json($_[1], 0x00000001); +} + + +# accessor + + +# pretty printing + +sub pretty { + my ($self, $v) = @_; + my $enable = defined $v ? $v : 1; + + if ($enable) { # indent_length(3) for JSON::XS compatibility + $self->indent(1)->space_before(1)->space_after(1); + } + else { + $self->indent(0)->space_before(0)->space_after(0); + } + + $self; +} + +# etc + +sub max_depth { + my $max = defined $_[1] ? $_[1] : 0x80000000; + $_[0]->{max_depth} = $max; + $_[0]; +} + + +sub get_max_depth { $_[0]->{max_depth}; } + + +sub max_size { + my $max = defined $_[1] ? $_[1] : 0; + $_[0]->{max_size} = $max; + $_[0]; +} + + +sub get_max_size { $_[0]->{max_size}; } + +sub boolean_values { + my $self = shift; + if (@_) { + my ($false, $true) = @_; + $self->{false} = $false; + $self->{true} = $true; + return ($false, $true); + } else { + delete $self->{false}; + delete $self->{true}; + return; + } +} + +sub get_boolean_values { + my $self = shift; + if (exists $self->{true} and exists $self->{false}) { + return @$self{qw/false true/}; + } + return; +} + +sub filter_json_object { + if (defined $_[1] and ref $_[1] eq 'CODE') { + $_[0]->{cb_object} = $_[1]; + } else { + delete $_[0]->{cb_object}; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; +} + +sub filter_json_single_key_object { + if (@_ == 1 or @_ > 3) { + Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)"); + } + if (defined $_[2] and ref $_[2] eq 'CODE') { + $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; + } else { + delete $_[0]->{cb_sk_object}->{$_[1]}; + delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}}; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; +} + +sub indent_length { + if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + $_[0]->{indent_length} = $_[1]; + } + $_[0]; +} + +sub get_indent_length { + $_[0]->{indent_length}; +} + +sub sort_by { + $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; + $_[0]; +} + +sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead."); + $_[0]->allow_bignum; +} + +############################### + +### +### Perl => JSON +### + + +{ # Convert + + my $max_depth; + my $indent; + my $ascii; + my $latin1; + my $utf8; + my $space_before; + my $space_after; + my $canonical; + my $allow_blessed; + my $convert_blessed; + + my $indent_length; + my $escape_slash; + my $bignum; + my $as_nonblessed; + my $allow_tags; + + my $depth; + my $indent_count; + my $keysort; + + + sub PP_encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + my $props = $self->{PROPS}; + + ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, + $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags) + = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, + P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS]; + + ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; + + $keysort = $canonical ? sub { $a cmp $b } : undef; + + if ($self->{sort_by}) { + $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} + : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} + : sub { $a cmp $b }; + } + + encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") + if(!ref $obj and !$props->[ P_ALLOW_NONREF ]); + + my $str = $self->object_to_json($obj); + + $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible + + unless ($ascii or $latin1 or $utf8) { + utf8::upgrade($str); + } + + if ($props->[ P_SHRINK ]) { + utf8::downgrade($str, 1); + } + + return $str; + } + + + sub object_to_json { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hash_to_json($obj); + } + elsif($type eq 'ARRAY'){ + return $self->array_to_json($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + + return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); + + if ( $allow_tags and $obj->can('FREEZE') ) { + my $obj_class = ref $obj || $obj; + $obj = bless $obj, $obj_class; + my @results = $obj->FREEZE('JSON'); + if ( @results and ref $results[0] ) { + if ( refaddr( $obj ) eq refaddr( $results[0] ) ) { + encode_error( sprintf( + "%s::FREEZE method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + } + return '("'.$obj_class.'")['.join(',', @results).']'; + } + + if ( $convert_blessed and $obj->can('TO_JSON') ) { + my $result = $obj->TO_JSON(); + if ( defined $result and ref( $result ) ) { + if ( refaddr( $obj ) eq refaddr( $result ) ) { + encode_error( sprintf( + "%s::TO_JSON method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + } + + return $self->object_to_json( $result ); + } + + return "$obj" if ( $bignum and _is_bignum($obj) ); + + if ($allow_blessed) { + return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed. + return 'null'; + } + encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj) + ); + } + else { + return $self->value_to_json($obj); + } + } + else{ + return $self->value_to_json($obj); + } + } + + + sub hash_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); + + for my $k ( _sort( $obj ) ) { + if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized + push @res, $self->string_to_json( $k ) + . $del + . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) ); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '{}' unless @res; + return '{' . $pre . join( ",$pre", @res ) . $post . '}'; + } + + + sub array_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + + for my $v (@$obj){ + push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '[]' unless @res; + return '[' . $pre . join( ",$pre", @res ) . $post . ']'; + } + + sub _looks_like_number { + my $value = shift; + if (USE_B) { + my $b_obj = B::svref_2object(\$value); + my $flags = $b_obj->FLAGS; + return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() ); + return; + } else { + no warnings 'numeric'; + # if the utf8 flag is on, it almost certainly started as a string + return if utf8::is_utf8($value); + # detect numbers + # string & "" -> "" + # number & "" -> 0 (with warning) + # nan and inf can detect as numbers, so check with * 0 + return unless length((my $dummy = "") & $value); + return unless 0 + $value eq $value; + return 1 if $value * 0 == 0; + return -1; # inf/nan + } + } + + sub value_to_json { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $type = ref($value); + + if (!$type) { + if (_looks_like_number($value)) { + return $value; + } + return $self->string_to_json($value); + } + elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ + return $$value == 1 ? 'true' : 'false'; + } + else { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->value_to_json("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' + : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' + : encode_error("cannot encode reference to scalar"); + } + + if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { + return 'null'; + } + else { + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + encode_error("cannot encode reference to scalar"); + } + else { + encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); + } + } + + } + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub string_to_json { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_PP_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_PP_encode_latin1($arg); + } + + if ($utf8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub blessed_to_json { + my $reftype = reftype($_[1]) || ''; + if ($reftype eq 'HASH') { + return $_[0]->hash_to_json($_[1]); + } + elsif ($reftype eq 'ARRAY') { + return $_[0]->array_to_json($_[1]); + } + else { + return 'null'; + } + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; + } + + + sub _up_indent { + my $self = shift; + my $space = ' ' x $indent_length; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _down_indent { $indent_count--; } + + + sub PP_encode_box { + { + depth => $depth, + indent_count => $indent_count, + }; + } + +} # Convert + + +sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); +} + + +sub _encode_surrogates { # from perlunicode + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); +} + + +sub _is_bignum { + $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); +} + + + +# +# JSON => Perl +# + +my $max_intsize; + +BEGIN { + my $checkint = 1111; + for my $d (5..64) { + $checkint .= 1; + my $int = eval qq| $checkint |; + if ($int =~ /[eE]/) { + $max_intsize = $d - 1; + last; + } + } +} + +{ # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + '"' => '"', + '/' => '/', + ); + + my $text; # json data + my $at; # offset + my $ch; # first character + my $len; # text length (changed according to UTF8 or NON UTF8) + # INTERNAL + my $depth; # nest counter + my $encoding; # json text encoding + my $is_valid_utf8; # temp variable + my $utf8_len; # utf8 byte length + # FLAGS + my $utf8; # must be utf8 + my $max_depth; # max nest number of objects and arrays + my $max_size; + my $relaxed; + my $cb_object; + my $cb_sk_object; + + my $F_HOOK; + + my $allow_bignum; # using Math::BigInt/BigFloat + my $singlequote; # loosely quoting + my $loose; # + my $allow_barekey; # bareKey + my $allow_tags; + + my $alt_true; + my $alt_false; + + sub _detect_utf_encoding { + my $text = shift; + my @octets = unpack('C4', $text); + return 'unknown' unless defined $octets[3]; + return ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + } + + sub PP_decode_json { + my ($self, $want_offset); + + ($self, $text, $want_offset) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if ( !defined $text or ref $text ) { + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + my $props = $self->{PROPS}; + + ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags) + = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS]; + + ($alt_true, $alt_false) = @$self{qw/true false/}; + + if ( $utf8 ) { + $encoding = _detect_utf_encoding($text); + if ($encoding ne 'UTF-8' and $encoding ne 'unknown') { + require Encode; + Encode::from_to($text, $encoding, 'utf-8'); + } else { + utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); + } + } + else { + utf8::upgrade( $text ); + utf8::encode( $text ); + } + + $len = length $text; + + ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) + = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; + + if ($max_size > 1) { + use bytes; + my $bytes = length $text; + decode_error( + sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" + , $bytes, $max_size), 1 + ) if ($bytes > $max_size); + } + + white(); # remove head white space + + decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure? + + my $result = value(); + + if ( !$props->[ P_ALLOW_NONREF ] and !ref $result ) { + decode_error( + 'JSON text must be an object or array (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + + Carp::croak('something wrong.') if $len < $at; # we won't arrive here. + + my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length + + white(); # remove tail white space + + return ( $result, $consumed ) if $want_offset; # all right if decode_prefix + + decode_error("garbage after JSON object") if defined $ch; + + $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return tag() if($ch eq '('); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch =~ /[0-9]/ or $ch eq '-'); + return word(); + } + + sub string { + my $utf16; + my $is_utf8; + + ($is_valid_utf8, $utf8_len) = ('', 0); + + my $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch; + + OUTER: while( defined(next_chr()) ){ + + if($ch eq $boundChar){ + next_chr(); + + if ($utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + utf8::decode($s) if($is_utf8); + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + $utf16 = $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (defined $utf16) { + decode_error("missing high surrogate character in surrogate pair"); + } + $is_utf8 = 1; + $s .= JSON_PP_decode_surrogates($utf16, $u) || next; + $utf16 = undef; + } + else { + if (defined $utf16) { + decode_error("surrogate pair expected"); + } + + if ( ( my $hex = hex( $u ) ) > 127 ) { + $is_utf8 = 1; + $s .= JSON_PP_decode_unicode($u) || next; + } + else { + $s .= chr $hex; + } + } + + } + else{ + unless ($loose) { + $at -= 2; + decode_error('illegal backslash escape sequence in string'); + } + $s .= $ch; + } + } + else{ + + if ( ord $ch > 127 ) { + unless( $ch = is_valid_utf8($ch) ) { + $at -= 1; + decode_error("malformed UTF-8 character in JSON string"); + } + else { + $at += $utf8_len - 1; + } + + $is_utf8 = 1; + } + + if (!$loose) { + if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok + if (!$relaxed or $ch ne "\t") { + $at--; + decode_error('invalid character encountered while parsing JSON string'); + } + } + } + + $s .= $ch; + } + } + } + + decode_error("unexpected end of string while parsing JSON string"); + } + + + sub white { + while( defined $ch ){ + if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){ + next_chr(); + } + elsif($relaxed and $ch eq '/'){ + next_chr(); + if(defined $ch and $ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif(defined $ch and $ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + $at--; + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + } + else{ + if ($relaxed and $ch eq '#') { # correctly? + pos($text) = $at; + $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; + $at = pos($text); + next_chr; + next; + } + + last; + } + } + } + + + sub array { + my $a = $_[0] || []; # you can use this code to use another array ref object. + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + + next_chr(); + white(); + + if(defined $ch and $ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + else { + while(defined($ch)){ + push @$a, value(); + + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq ']') { + --$depth; + next_chr(); + return $a; + } + + } + } + + $at-- if defined $ch and $ch ne ''; + decode_error(", or ] expected while parsing array"); + } + + sub tag { + decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags; + + next_chr(); + white(); + + my $tag = value(); + return unless defined $tag; + decode_error('malformed JSON string, (tag) must be a string') if ref $tag; + + white(); + + if (!defined $ch or $ch ne ')') { + decode_error(') expected after tag'); + } + + next_chr(); + white(); + + my $val = value(); + return unless defined $val; + decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY'; + + if (!eval { $tag->can('THAW') }) { + decode_error('cannot decode perl-object (package does not exist)') if $@; + decode_error('cannot decode perl-object (package does not have a THAW method)'); + } + $tag->THAW('JSON', @$val); + } + + sub object { + my $o = $_[0] || {}; # you can use this code to use another hash ref object. + my $k; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + next_chr(); + white(); + + if(defined $ch and $ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + else { + while (defined $ch) { + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + $at--; + decode_error("':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq '}') { + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + } + + } + + $at-- if defined $ch and $ch ne ''; + decode_error(", or } expected while parsing object/hash"); + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return defined $alt_true ? $alt_true : $JSON::PP::true; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return defined $alt_false ? $alt_false : $JSON::PP::false; + } + } + + $at--; # for decode_error report + + decode_error("'null' expected") if ($word =~ /^n/); + decode_error("'true' expected") if ($word =~ /^t/); + decode_error("'false' expected") if ($word =~ /^f/); + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + my $is_dec; + my $is_exp; + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + # According to RFC4627, hex or oct digits are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential) + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $n .= $ch; + next_chr; + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + $is_dec = 1; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + $is_exp = 1; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-')){ + $n .= $ch; + next_chr; + if (!defined $ch or $ch =~ /\D/) { + decode_error("malformed number (no digits after exp sign)"); + } + $n .= $ch; + } + elsif(defined($ch) and $ch =~ /\d/){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($is_dec or $is_exp) { + if ($allow_bignum) { + require Math::BigFloat; + return Math::BigFloat->new($v); + } + } else { + if (length $v > $max_intsize) { + if ($allow_bignum) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v); + } + else { + return "$v"; + } + } + } + + return $is_dec ? $v/1.0 : 0+$v; + } + + + sub is_valid_utf8 { + + $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 + : $_[0] =~ /[\xC2-\xDF]/ ? 2 + : $_[0] =~ /[\xE0-\xEF]/ ? 3 + : $_[0] =~ /[\xF0-\xF4]/ ? 4 + : 0 + ; + + return unless $utf8_len; + + my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); + + return ( $is_valid_utf8 =~ /^(?: + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + )$/x ) ? $is_valid_utf8 : ''; + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + my $mess = ''; + my $type = 'U*'; + + if ( OLD_PERL ) { + my $type = $] < 5.006 ? 'C*' + : utf8::is_utf8( $str ) ? 'U*' # 5.6 + : 'C*' + ; + } + + for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? + $mess .= $c == 0x07 ? '\a' + : $c == 0x09 ? '\t' + : $c == 0x0a ? '\n' + : $c == 0x0d ? '\r' + : $c == 0x0c ? '\f' + : $c < 0x20 ? sprintf('\x{%x}', $c) + : $c == 0x5c ? '\\\\' + : $c < 0x80 ? chr($c) + : sprintf('\x{%x}', $c) + ; + if ( length $mess >= 20 ) { + $mess .= '...'; + last; + } + } + + unless ( length $mess ) { + $mess = '(end of string)'; + } + + Carp::croak ( + $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" + ); + + } + + + sub _json_object_hook { + my $o = $_[0]; + my @ks = keys %{$o}; + + if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { + my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); + if (@val == 0) { + return $o; + } + elsif (@val == 1) { + return $val[0]; + } + else { + Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar"); + } + } + + my @val = $cb_object->($o) if ($cb_object); + if (@val == 0) { + return $o; + } + elsif (@val == 1) { + return $val[0]; + } + else { + Carp::croak("filter_json_object callbacks must not return more than one scalar"); + } + } + + + sub PP_decode_box { + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + } + +} # PARSE + + +sub _decode_surrogates { # from perlunicode + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); + my $un = pack('U*', $uni); + utf8::encode( $un ); + return $un; +} + + +sub _decode_unicode { + my $un = pack('U', hex shift); + utf8::encode( $un ); + return $un; +} + +# +# Setup for various Perl versions (the code from JSON::PP58) +# + +BEGIN { + + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } + + if ( !OLD_PERL ) { + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + + if ($] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. + package JSON::PP; + require subs; + subs->import('join'); + eval q| + sub join { + return '' if (@_ < 2); + my $j = shift; + my $str = shift; + for (@_) { $str .= $j . $_; } + return $str; + } + |; + } + } + + + sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); + } + + + sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; + } + + + sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; + } + + eval q{ + sub JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_pos} ) { + Carp::croak("incr_text cannot be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; + } + } if ( $] >= 5.006 ); + +} # Setup for various Perl versions (the code from JSON::PP58) + + +############################### +# Utilities +# + +BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + *JSON::PP::reftype = \&Scalar::Util::reftype; + *JSON::PP::refaddr = \&Scalar::Util::refaddr; + } + else{ # This code is from Scalar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + require B; + my %tmap = qw( + B::NULL SCALAR + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::GV GLOB + B::REGEXP REGEXP + ); + *JSON::PP::reftype = sub { + my $r = shift; + + return undef unless length(ref($r)); + + my $t = ref(B::svref_2object($r)); + + return + exists $tmap{$t} ? $tmap{$t} + : length(ref($$r)) ? 'REF' + : 'SCALAR'; + }; + *JSON::PP::refaddr = sub { + return undef unless length(ref($_[0])); + + my $addr; + if(defined(my $pkg = blessed($_[0]))) { + $addr .= bless $_[0], 'Scalar::Util::Fake'; + bless $_[0], $pkg; + } + else { + $addr .= $_[0] + } + + $addr =~ /0x(\w+)/; + local $^W; + #no warnings 'portable'; + hex($1); + } + } +} + + +# shamelessly copied and modified from JSON::XS code. + +$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; +$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; + +sub is_bool { blessed $_[0] and ( $_[0]->isa("JSON::PP::Boolean") or $_[0]->isa("Types::Serialiser::BooleanBase") or $_[0]->isa("JSON::XS::Boolean") ); } + +sub true { $JSON::PP::true } +sub false { $JSON::PP::false } +sub null { undef; } + +############################### + +package JSON::PP::IncrParser; + +use strict; + +use constant INCR_M_WS => 0; # initial whitespace skipping +use constant INCR_M_STR => 1; # inside string +use constant INCR_M_BS => 2; # inside backslash +use constant INCR_M_JSON => 3; # outside anything, count nesting +use constant INCR_M_C0 => 4; +use constant INCR_M_C1 => 5; +use constant INCR_M_TFN => 6; +use constant INCR_M_NUM => 7; + +$JSON::PP::IncrParser::VERSION = '1.01'; + +sub new { + my ( $class ) = @_; + + bless { + incr_nest => 0, + incr_text => undef, + incr_pos => 0, + incr_mode => 0, + }, $class; +} + + +sub incr_parse { + my ( $self, $coder, $text ) = @_; + + $self->{incr_text} = '' unless ( defined $self->{incr_text} ); + + if ( defined $text ) { + if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { + utf8::upgrade( $self->{incr_text} ) ; + utf8::decode( $self->{incr_text} ) ; + } + $self->{incr_text} .= $text; + } + + if ( defined wantarray ) { + my $max_size = $coder->get_max_size; + my $p = $self->{incr_pos}; + my @ret; + { + do { + unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) { + $self->_incr_parse( $coder ); + + if ( $max_size and $self->{incr_pos} > $max_size ) { + Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size"); + } + unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) { + # as an optimisation, do not accumulate white space in the incr buffer + if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) { + $self->{incr_pos} = 0; + $self->{incr_text} = ''; + } + last; + } + } + + my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 ); + push @ret, $obj; + use bytes; + $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 ); + $self->{incr_pos} = 0; + $self->{incr_nest} = 0; + $self->{incr_mode} = 0; + last unless wantarray; + } while ( wantarray ); + } + + if ( wantarray ) { + return @ret; + } + else { # in scalar context + return defined $ret[0] ? $ret[0] : undef; + } + } +} + + +sub _incr_parse { + my ($self, $coder) = @_; + my $text = $self->{incr_text}; + my $len = length $text; + my $p = $self->{incr_pos}; + +INCR_PARSE: + while ( $len > $p ) { + my $s = substr( $text, $p, 1 ); + last INCR_PARSE unless defined $s; + my $mode = $self->{incr_mode}; + + if ( $mode == INCR_M_WS ) { + while ( $len > $p ) { + $s = substr( $text, $p, 1 ); + last INCR_PARSE unless defined $s; + if ( ord($s) > 0x20 ) { + if ( $s eq '#' ) { + $self->{incr_mode} = INCR_M_C0; + redo INCR_PARSE; + } else { + $self->{incr_mode} = INCR_M_JSON; + redo INCR_PARSE; + } + } + $p++; + } + } elsif ( $mode == INCR_M_BS ) { + $p++; + $self->{incr_mode} = INCR_M_STR; + redo INCR_PARSE; + } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) { + while ( $len > $p ) { + $s = substr( $text, $p, 1 ); + last INCR_PARSE unless defined $s; + if ( $s eq "\n" ) { + $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON; + last; + } + $p++; + } + next; + } elsif ( $mode == INCR_M_TFN ) { + while ( $len > $p ) { + $s = substr( $text, $p++, 1 ); + next if defined $s and $s =~ /[rueals]/; + last; + } + $p--; + $self->{incr_mode} = INCR_M_JSON; + + last INCR_PARSE unless $self->{incr_nest}; + redo INCR_PARSE; + } elsif ( $mode == INCR_M_NUM ) { + while ( $len > $p ) { + $s = substr( $text, $p++, 1 ); + next if defined $s and $s =~ /[0-9eE.+\-]/; + last; + } + $p--; + $self->{incr_mode} = INCR_M_JSON; + + last INCR_PARSE unless $self->{incr_nest}; + redo INCR_PARSE; + } elsif ( $mode == INCR_M_STR ) { + while ( $len > $p ) { + $s = substr( $text, $p, 1 ); + last INCR_PARSE unless defined $s; + if ( $s eq '"' ) { + $p++; + $self->{incr_mode} = INCR_M_JSON; + + last INCR_PARSE unless $self->{incr_nest}; + redo INCR_PARSE; + } + elsif ( $s eq '\\' ) { + $p++; + if ( !defined substr($text, $p, 1) ) { + $self->{incr_mode} = INCR_M_BS; + last INCR_PARSE; + } + } + $p++; + } + } elsif ( $mode == INCR_M_JSON ) { + while ( $len > $p ) { + $s = substr( $text, $p++, 1 ); + if ( $s eq "\x00" ) { + $p--; + last INCR_PARSE; + } elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) { + if ( !$self->{incr_nest} ) { + $p--; # do not eat the whitespace, let the next round do it + last INCR_PARSE; + } + next; + } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) { + $self->{incr_mode} = INCR_M_TFN; + redo INCR_PARSE; + } elsif ( $s =~ /^[0-9\-]$/ ) { + $self->{incr_mode} = INCR_M_NUM; + redo INCR_PARSE; + } elsif ( $s eq '"' ) { + $self->{incr_mode} = INCR_M_STR; + redo INCR_PARSE; + } elsif ( $s eq '[' or $s eq '{' ) { + if ( ++$self->{incr_nest} > $coder->get_max_depth ) { + Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); + } + next; + } elsif ( $s eq ']' or $s eq '}' ) { + if ( --$self->{incr_nest} <= 0 ) { + last INCR_PARSE; + } + } elsif ( $s eq '#' ) { + $self->{incr_mode} = INCR_M_C1; + redo INCR_PARSE; + } + } + } + } + + $self->{incr_pos} = $p; + $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility +} + + +sub incr_text { + if ( $_[0]->{incr_pos} ) { + Carp::croak("incr_text cannot be called when the incremental parser already started parsing"); + } + $_[0]->{incr_text}; +} + + +sub incr_skip { + my $self = shift; + $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} ); + $self->{incr_pos} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; +} + + +sub incr_reset { + my $self = shift; + $self->{incr_text} = undef; + $self->{incr_pos} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; +} + +############################### + + +1; +__END__ +#line 3148 diff --git a/apps/lib/JSON/PP/Boolean.pm b/apps/lib/JSON/PP/Boolean.pm new file mode 100644 index 0000000..8776805 --- /dev/null +++ b/apps/lib/JSON/PP/Boolean.pm @@ -0,0 +1,21 @@ +#line 1 "JSON/PP/Boolean.pm" +package JSON::PP::Boolean; + +use strict; +require overload; +local $^W; +overload::import('overload', + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, +); + +$JSON::PP::Boolean::VERSION = '4.02'; + +1; + +__END__ + +#line 42 + diff --git a/apps/lib/Template.pm b/apps/lib/Template.pm new file mode 100644 index 0000000..5a1379c --- /dev/null +++ b/apps/lib/Template.pm @@ -0,0 +1,230 @@ +#line 1 "Template.pm" +#============================================================= -*-perl-*- +# +# Template +# +# DESCRIPTION +# Module implementing a simple, user-oriented front-end to the Template +# Toolkit. +# +# AUTHOR +# Andy Wardley +# +# COPYRIGHT +# Copyright (C) 1996-2014 Andy Wardley. All Rights Reserved. +# +# This module is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +#======================================================================== + +package Template; + +use strict; +use warnings; +use 5.006; +use base 'Template::Base'; + +use Template::Config; +use Template::Constants; +use Template::Provider; +use Template::Service; +use File::Basename; +use File::Path; +use Scalar::Util qw(blessed); + +our $VERSION = '2.28'; +our $ERROR = ''; +our $DEBUG = 0; +our $BINMODE = 0 unless defined $BINMODE; +our $AUTOLOAD; + +# preload all modules if we're running under mod_perl +Template::Config->preload() if $ENV{ MOD_PERL }; + + +#------------------------------------------------------------------------ +# process($input, \%replace, $output) +# +# Main entry point for the Template Toolkit. The Template module +# delegates most of the processing effort to the underlying SERVICE +# object, an instance of the Template::Service class. +#------------------------------------------------------------------------ + +sub process { + my ($self, $template, $vars, $outstream, @opts) = @_; + my ($output, $error); + my $options = (@opts == 1) && ref($opts[0]) eq 'HASH' + ? shift(@opts) : { @opts }; + + $options->{ binmode } = $BINMODE + unless defined $options->{ binmode }; + + # we're using this for testing in t/output.t and t/filter.t so + # don't remove it if you don't want tests to fail... + $self->DEBUG("set binmode\n") if $DEBUG && $options->{ binmode }; + + $output = $self->{ SERVICE }->process($template, $vars); + + if (defined $output) { + $outstream ||= $self->{ OUTPUT }; + unless (ref $outstream) { + my $outpath = $self->{ OUTPUT_PATH }; + $outstream = "$outpath/$outstream" if $outpath; + } + + # send processed template to output stream, checking for error + return ($self->error($error)) + if ($error = &_output($outstream, \$output, $options)); + + return 1; + } + else { + return $self->error($self->{ SERVICE }->error); + } +} + + +#------------------------------------------------------------------------ +# service() +# +# Returns a reference to the internal SERVICE object which handles +# all requests for this Template object +#------------------------------------------------------------------------ + +sub service { + my $self = shift; + return $self->{ SERVICE }; +} + + +#------------------------------------------------------------------------ +# context() +# +# Returns a reference to the CONTEXT object within the SERVICE +# object. +#------------------------------------------------------------------------ + +sub context { + my $self = shift; + return $self->{ SERVICE }->{ CONTEXT }; +} + +sub template { + shift->context->template(@_); +} + + +#======================================================================== +# -- PRIVATE METHODS -- +#======================================================================== + +#------------------------------------------------------------------------ +# _init(\%config) +#------------------------------------------------------------------------ +sub _init { + my ($self, $config) = @_; + + # convert any textual DEBUG args to numerical form + my $debug = $config->{ DEBUG }; + $config->{ DEBUG } = Template::Constants::debug_flags($self, $debug) + || return if defined $debug && $debug !~ /^\d+$/; + + # prepare a namespace handler for any CONSTANTS definition + if (my $constants = $config->{ CONSTANTS }) { + my $ns = $config->{ NAMESPACE } ||= { }; + my $cns = $config->{ CONSTANTS_NAMESPACE } || 'constants'; + $constants = Template::Config->constants($constants) + || return $self->error(Template::Config->error); + $ns->{ $cns } = $constants; + } + + $self->{ SERVICE } = $config->{ SERVICE } + || Template::Config->service($config) + || return $self->error(Template::Config->error); + + $self->{ OUTPUT } = $config->{ OUTPUT } || \*STDOUT; + $self->{ OUTPUT_PATH } = $config->{ OUTPUT_PATH }; + + return $self; +} + + +#------------------------------------------------------------------------ +# _output($where, $text) +#------------------------------------------------------------------------ + +sub _output { + my ($where, $textref, $options) = @_; + my $reftype; + my $error = 0; + + # call a CODE reference + if (($reftype = ref($where)) eq 'CODE') { + &$where($$textref); + } + # print to a glob (such as \*STDOUT) + elsif ($reftype eq 'GLOB') { + print $where $$textref; + } + # append output to a SCALAR ref + elsif ($reftype eq 'SCALAR') { + $$where .= $$textref; + } + # push onto ARRAY ref + elsif ($reftype eq 'ARRAY') { + push @$where, $$textref; + } + # call the print() method on an object that implements the method + # (e.g. IO::Handle, Apache::Request, etc) + elsif (blessed($where) && $where->can('print')) { + $where->print($$textref); + } + # a simple string is taken as a filename + elsif (! $reftype) { + local *FP; + # make destination directory if it doesn't exist + my $dir = dirname($where); + eval { mkpath($dir) unless -d $dir; }; + if ($@) { + # strip file name and line number from error raised by die() + ($error = $@) =~ s/ at \S+ line \d+\n?$//; + } + elsif (open(FP, ">$where")) { + # binmode option can be 1 or a specific layer, e.g. :utf8 + my $bm = $options->{ binmode }; + if ($bm && $bm eq 1) { + binmode FP; + } + elsif ($bm){ + binmode FP, $bm; + } + print FP $$textref; + close FP; + } + else { + $error = "$where: $!"; + } + } + # give up, we've done our best + else { + $error = "output_handler() cannot determine target type ($where)\n"; + } + + return $error; +} + + +1; + +__END__ + +#line 928 + +# Local Variables: +# mode: perl +# perl-indent-level: 4 +# indent-tabs-mode: nil +# End: +# +# vim: expandtab shiftwidth=4: diff --git a/lib/Template/Base.pm b/apps/lib/Template/Base.pm similarity index 54% rename from lib/Template/Base.pm rename to apps/lib/Template/Base.pm index 8380499..0466938 100644 --- a/lib/Template/Base.pm +++ b/apps/lib/Template/Base.pm @@ -1,3 +1,4 @@ +#line 1 "Template/Base.pm" #============================================================= -*-perl-*- # # Template::Base @@ -143,136 +144,7 @@ sub module_version { __END__ -=head1 NAME - -Template::Base - Base class module implementing common functionality - -=head1 SYNOPSIS - - package My::Module; - use base qw( Template::Base ); - - sub _init { - my ($self, $config) = @_; - $self->{ doodah } = $config->{ doodah } - || return $self->error("No 'doodah' specified"); - return $self; - } - - package main; - - my $object = My::Module->new({ doodah => 'foobar' }) - || die My::Module->error(); - -=head1 DESCRIPTION - -Base class module which implements a constructor and error reporting -functionality for various Template Toolkit modules. - -=head1 PUBLIC METHODS - -=head2 new(\%config) - -Constructor method which accepts a reference to a hash array or a list -of C value> parameters which are folded into a hash. The -C<_init()> method is then called, passing the configuration hash and should -return true/false to indicate success or failure. A new object reference -is returned, or undef on error. Any error message raised can be examined -via the L class method or directly via the C<$ERROR> package variable -in the derived class. - - my $module = My::Module->new({ ... }) - || die My::Module->error(), "\n"; - - my $module = My::Module->new({ ... }) - || die "constructor error: $My::Module::ERROR\n"; - -=head2 error($msg, ...) - -May be called as an object method to get/set the internal C<_ERROR> member -or as a class method to get/set the C<$ERROR> variable in the derived class's -package. - - my $module = My::Module->new({ ... }) - || die My::Module->error(), "\n"; - - $module->do_something() - || die $module->error(), "\n"; - -When called with parameters (multiple params are concatenated), this -method will set the relevant variable and return undef. This is most -often used within object methods to report errors to the caller. - - package My::Module; - - sub foobar { - my $self = shift; - - # some other code... - - return $self->error('some kind of error...') - if $some_condition; - } - -=head2 debug($msg, ...) - -Generates a debugging message by concatenating all arguments -passed into a string and printing it to C. A prefix is -added to indicate the module of the caller. - - package My::Module; - - sub foobar { - my $self = shift; - - $self->debug('called foobar()'); - - # some other code... - } - -When the C method is called, the following message -is sent to C: - - [My::Module] called foobar() - -Objects can set an internal C value which the C -method will examine. If this value sets the relevant bits -to indicate C then the file and line number of -the caller will be append to the message. - - use Template::Constants qw( :debug ); - - my $module = My::Module->new({ - DEBUG => DEBUG_SERVICE | DEBUG_CONTEXT | DEBUG_CALLER, - }); - - $module->foobar(); - -This generates an error message such as: - - [My::Module] called foobar() at My/Module.pm line 6 - -=head2 module_version() - -Returns the version number for a module, as defined by the C<$VERSION> -package variable. - -=head1 AUTHOR - -Andy Wardley Eabw@wardley.orgE L - -=head1 COPYRIGHT - -Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. - -This module is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 SEE ALSO - -L