From: Laurent Dami Date: Thu, 16 Oct 2008 22:49:55 +0000 (+0000) Subject: (no commit message) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96449e8ea5159e5448ebfc81dfa200dc674f366b;p=scpubgit%2FQ-Branch.git --- diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..d44f80c --- /dev/null +++ b/MANIFEST @@ -0,0 +1,13 @@ +Changes +INSTALL +lib/SQL/Abstract.pm +Makefile.PL +MANIFEST This list of files +t/00new.t +t/01generate.t +t/02where.t +t/03values.t +t/06order_by.t +t/07subqueries.t +t/08special_ops.t +t/TestSqlAbstract.pm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..f95ae68 --- /dev/null +++ b/Makefile @@ -0,0 +1,810 @@ +# This Makefile is for the SQL::Abstract extension to perl. +# +# It was generated automatically by MakeMaker version +# 6.44 (Revision: 54639) from the contents of +# Makefile.PL. Don't edit this file, edit Makefile.PL instead. +# +# ANY CHANGES MADE HERE WILL BE LOST! +# +# MakeMaker ARGV: () +# +# MakeMaker Parameters: + +# ABSTRACT_FROM => q[lib/SQL/Abstract.pm] +# AUTHOR => q[Nathan Wiger (nate@wiger.org)] +# NAME => q[SQL::Abstract] +# PREREQ_PM => { List::Util=>q[0] } +# VERSION_FROM => q[lib/SQL/Abstract.pm] + +# --- MakeMaker post_initialize section: + + +# --- MakeMaker const_config section: + +# These definitions are from config.sh (via d:/Perl/lib/Config.pm). +# They may have been overridden via Makefile.PL or on the command line. +AR = ar +CC = gcc +CCCDLFLAGS = +CCDLFLAGS = +DLEXT = dll +DLSRC = dl_win32.xs +EXE_EXT = .exe +FULL_AR = +LD = g++ +LDDLFLAGS = -mdll -L"d:\perl\lib\CORE" +LDFLAGS = -L"d:\perl\lib\CORE" +LIBC = msvcrt.lib +LIB_EXT = .a +OBJ_EXT = .o +OSNAME = MSWin32 +OSVERS = 5.00 +RANLIB = rem +SITELIBEXP = d:\Perl\site\lib +SITEARCHEXP = d:\Perl\site\lib +SO = dll +VENDORARCHEXP = +VENDORLIBEXP = + + +# --- MakeMaker constants section: +AR_STATIC_ARGS = cr +DIRFILESEP = ^\ +DFSEP = $(DIRFILESEP) +NAME = SQL::Abstract +NAME_SYM = SQL_Abstract +VERSION = 1.49_01 +VERSION_MACRO = VERSION +VERSION_SYM = 1_49_01 +DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\" +XS_VERSION = 1.49_01 +XS_VERSION_MACRO = XS_VERSION +XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\" +INST_ARCHLIB = blib\arch +INST_SCRIPT = blib\script +INST_BIN = blib\bin +INST_LIB = blib\lib +INST_MAN1DIR = blib\man1 +INST_MAN3DIR = blib\man3 +MAN1EXT = 1 +MAN3EXT = 3 +INSTALLDIRS = site +DESTDIR = +PREFIX = $(SITEPREFIX) +PERLPREFIX = d:\perl +SITEPREFIX = d:\perl\site +VENDORPREFIX = +INSTALLPRIVLIB = d:\perl\lib +DESTINSTALLPRIVLIB = $(DESTDIR)$(INSTALLPRIVLIB) +INSTALLSITELIB = d:\perl\site\lib +DESTINSTALLSITELIB = $(DESTDIR)$(INSTALLSITELIB) +INSTALLVENDORLIB = +DESTINSTALLVENDORLIB = $(DESTDIR)$(INSTALLVENDORLIB) +INSTALLARCHLIB = d:\perl\lib +DESTINSTALLARCHLIB = $(DESTDIR)$(INSTALLARCHLIB) +INSTALLSITEARCH = d:\perl\site\lib +DESTINSTALLSITEARCH = $(DESTDIR)$(INSTALLSITEARCH) +INSTALLVENDORARCH = +DESTINSTALLVENDORARCH = $(DESTDIR)$(INSTALLVENDORARCH) +INSTALLBIN = d:\perl\bin +DESTINSTALLBIN = $(DESTDIR)$(INSTALLBIN) +INSTALLSITEBIN = d:\perl\site\bin +DESTINSTALLSITEBIN = $(DESTDIR)$(INSTALLSITEBIN) +INSTALLVENDORBIN = +DESTINSTALLVENDORBIN = $(DESTDIR)$(INSTALLVENDORBIN) +INSTALLSCRIPT = d:\perl\bin +DESTINSTALLSCRIPT = $(DESTDIR)$(INSTALLSCRIPT) +INSTALLSITESCRIPT = $(INSTALLSCRIPT) +DESTINSTALLSITESCRIPT = $(DESTDIR)$(INSTALLSITESCRIPT) +INSTALLVENDORSCRIPT = +DESTINSTALLVENDORSCRIPT = $(DESTDIR)$(INSTALLVENDORSCRIPT) +INSTALLMAN1DIR = d:\perl\man\man1 +DESTINSTALLMAN1DIR = $(DESTDIR)$(INSTALLMAN1DIR) +INSTALLSITEMAN1DIR = $(INSTALLMAN1DIR) +DESTINSTALLSITEMAN1DIR = $(DESTDIR)$(INSTALLSITEMAN1DIR) +INSTALLVENDORMAN1DIR = +DESTINSTALLVENDORMAN1DIR = $(DESTDIR)$(INSTALLVENDORMAN1DIR) +INSTALLMAN3DIR = d:\perl\man\man3 +DESTINSTALLMAN3DIR = $(DESTDIR)$(INSTALLMAN3DIR) +INSTALLSITEMAN3DIR = $(INSTALLMAN3DIR) +DESTINSTALLSITEMAN3DIR = $(DESTDIR)$(INSTALLSITEMAN3DIR) +INSTALLVENDORMAN3DIR = +DESTINSTALLVENDORMAN3DIR = $(DESTDIR)$(INSTALLVENDORMAN3DIR) +PERL_LIB = d:\Perl\lib +PERL_ARCHLIB = d:\Perl\lib +LIBPERL_A = libperl.a +FIRST_MAKEFILE = Makefile +MAKEFILE_OLD = Makefile.old +MAKE_APERL_FILE = Makefile.aperl +PERLMAINCC = $(CC) +PERL_INC = D:\Perl\lib\CORE +PERL = D:\Perl\bin\perl.exe +FULLPERL = D:\Perl\bin\perl.exe +ABSPERL = $(PERL) +PERLRUN = $(PERL) +FULLPERLRUN = $(FULLPERL) +ABSPERLRUN = $(ABSPERL) +PERLRUNINST = $(PERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" +FULLPERLRUNINST = $(FULLPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" +ABSPERLRUNINST = $(ABSPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" +PERL_CORE = 0 +PERM_RW = 644 +PERM_RWX = 755 + +MAKEMAKER = d:/Perl/lib/ExtUtils/MakeMaker.pm +MM_VERSION = 6.44 +MM_REVISION = 54639 + +# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) +# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +MAKE = nmake +FULLEXT = SQL\Abstract +BASEEXT = Abstract +PARENT_NAME = SQL +DLBASE = $(BASEEXT) +VERSION_FROM = lib/SQL/Abstract.pm +OBJECT = +LDFROM = $(OBJECT) +LINKTYPE = dynamic +BOOTDEP = + +# Handy lists of source code files: +XS_FILES = +C_FILES = +O_FILES = +H_FILES = +MAN1PODS = +MAN3PODS = lib/SQL/Abstract.pm + +# Where is the Config information that we are using/depend on +CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h + +# Where to build things +INST_LIBDIR = $(INST_LIB)\SQL +INST_ARCHLIBDIR = $(INST_ARCHLIB)\SQL + +INST_AUTODIR = $(INST_LIB)\auto\$(FULLEXT) +INST_ARCHAUTODIR = $(INST_ARCHLIB)\auto\$(FULLEXT) + +INST_STATIC = +INST_DYNAMIC = +INST_BOOT = + +# Extra linker info +EXPORT_LIST = $(BASEEXT).def +PERL_ARCHIVE = $(PERL_INC)\perl58.lib +PERL_ARCHIVE_AFTER = + + +TO_INST_PM = lib/SQL/Abstract.pm + +PM_TO_BLIB = lib/SQL/Abstract.pm \ + blib\lib\SQL\Abstract.pm + + +# --- MakeMaker platform_constants section: +MM_Win32_VERSION = 6.44 + + +# --- MakeMaker tool_autosplit section: +# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto +AUTOSPLITFILE = $(ABSPERLRUN) -e "use AutoSplit; autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)" -- + + + +# --- MakeMaker tool_xsubpp section: + + +# --- MakeMaker tools_other section: +CHMOD = $(ABSPERLRUN) -MExtUtils::Command -e chmod +CP = $(ABSPERLRUN) -MExtUtils::Command -e cp +MV = $(ABSPERLRUN) -MExtUtils::Command -e mv +NOOP = rem +NOECHO = @ +RM_F = $(ABSPERLRUN) -MExtUtils::Command -e rm_f +RM_RF = $(ABSPERLRUN) -MExtUtils::Command -e rm_rf +TEST_F = $(ABSPERLRUN) -MExtUtils::Command -e test_f +TOUCH = $(ABSPERLRUN) -MExtUtils::Command -e touch +UMASK_NULL = umask 0 +DEV_NULL = > NUL +MKPATH = $(ABSPERLRUN) "-MExtUtils::Command" -e mkpath +EQUALIZE_TIMESTAMP = $(ABSPERLRUN) "-MExtUtils::Command" -e eqtime +ECHO = $(ABSPERLRUN) -l -e "print qq{@ARGV}" -- +ECHO_N = $(ABSPERLRUN) -e "print qq{@ARGV}" -- +UNINST = 0 +VERBINST = 0 +MOD_INSTALL = $(ABSPERLRUN) -MExtUtils::Install -e "install({@ARGV}, '$(VERBINST)', 0, '$(UNINST)');" -- +DOC_INSTALL = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e perllocal_install +UNINSTALL = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e uninstall +WARN_IF_OLD_PACKLIST = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e warn_if_old_packlist +MACROSTART = +MACROEND = +USEMAKEFILE = -f +FIXIN = pl2bat.bat + + +# --- MakeMaker makemakerdflt section: +makemakerdflt : all + $(NOECHO) $(NOOP) + + +# --- MakeMaker dist section: +TAR = tar +TARFLAGS = cvf +ZIP = zip +ZIPFLAGS = -r +COMPRESS = gzip --best +SUFFIX = .gz +SHAR = shar +PREOP = $(NOECHO) $(NOOP) +POSTOP = $(NOECHO) $(NOOP) +TO_UNIX = $(NOECHO) $(NOOP) +CI = ci -u +RCS_LABEL = rcs -Nv$(VERSION_SYM): -q +DIST_CP = best +DIST_DEFAULT = tardist +DISTNAME = SQL-Abstract +DISTVNAME = SQL-Abstract-1.49_01 + + +# --- MakeMaker macro section: + + +# --- MakeMaker depend section: + + +# --- MakeMaker cflags section: + + +# --- MakeMaker const_loadlibs section: + + +# --- MakeMaker const_cccmd section: + + +# --- MakeMaker post_constants section: + + +# --- MakeMaker pasthru section: +PASTHRU = -nologo + +# --- MakeMaker special_targets section: +.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) + +.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir + + + +# --- MakeMaker c_o section: + + +# --- MakeMaker xs_c section: + + +# --- MakeMaker xs_o section: + + +# --- MakeMaker top_targets section: +all :: pure_all + $(NOECHO) $(NOOP) + + +pure_all :: config pm_to_blib subdirs linkext + $(NOECHO) $(NOOP) + +subdirs :: $(MYEXTLIB) + $(NOECHO) $(NOOP) + +config :: $(FIRST_MAKEFILE) blibdirs + $(NOECHO) $(NOOP) + +help : + perldoc ExtUtils::MakeMaker + + +# --- MakeMaker blibdirs section: +blibdirs : $(INST_LIBDIR)$(DFSEP).exists $(INST_ARCHLIB)$(DFSEP).exists $(INST_AUTODIR)$(DFSEP).exists $(INST_ARCHAUTODIR)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists $(INST_SCRIPT)$(DFSEP).exists $(INST_MAN1DIR)$(DFSEP).exists $(INST_MAN3DIR)$(DFSEP).exists + $(NOECHO) $(NOOP) + +# Backwards compat with 6.18 through 6.25 +blibdirs.ts : blibdirs + $(NOECHO) $(NOOP) + +$(INST_LIBDIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_LIBDIR) + $(NOECHO) $(CHMOD) 755 $(INST_LIBDIR) + $(NOECHO) $(TOUCH) $(INST_LIBDIR)$(DFSEP).exists + +$(INST_ARCHLIB)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_ARCHLIB) + $(NOECHO) $(CHMOD) 755 $(INST_ARCHLIB) + $(NOECHO) $(TOUCH) $(INST_ARCHLIB)$(DFSEP).exists + +$(INST_AUTODIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_AUTODIR) + $(NOECHO) $(CHMOD) 755 $(INST_AUTODIR) + $(NOECHO) $(TOUCH) $(INST_AUTODIR)$(DFSEP).exists + +$(INST_ARCHAUTODIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) + $(NOECHO) $(CHMOD) 755 $(INST_ARCHAUTODIR) + $(NOECHO) $(TOUCH) $(INST_ARCHAUTODIR)$(DFSEP).exists + +$(INST_BIN)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_BIN) + $(NOECHO) $(CHMOD) 755 $(INST_BIN) + $(NOECHO) $(TOUCH) $(INST_BIN)$(DFSEP).exists + +$(INST_SCRIPT)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_SCRIPT) + $(NOECHO) $(CHMOD) 755 $(INST_SCRIPT) + $(NOECHO) $(TOUCH) $(INST_SCRIPT)$(DFSEP).exists + +$(INST_MAN1DIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_MAN1DIR) + $(NOECHO) $(CHMOD) 755 $(INST_MAN1DIR) + $(NOECHO) $(TOUCH) $(INST_MAN1DIR)$(DFSEP).exists + +$(INST_MAN3DIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_MAN3DIR) + $(NOECHO) $(CHMOD) 755 $(INST_MAN3DIR) + $(NOECHO) $(TOUCH) $(INST_MAN3DIR)$(DFSEP).exists + + + +# --- MakeMaker linkext section: + +linkext :: $(LINKTYPE) + $(NOECHO) $(NOOP) + + +# --- MakeMaker dlsyms section: + +Abstract.def: Makefile.PL + $(PERLRUN) -MExtUtils::Mksymlists \ + -e "Mksymlists('NAME'=>\"SQL::Abstract\", 'DLBASE' => '$(BASEEXT)', 'DL_FUNCS' => { }, 'FUNCLIST' => [], 'IMPORTS' => { }, 'DL_VARS' => []);" + + +# --- MakeMaker dynamic section: + +dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT) + $(NOECHO) $(NOOP) + + +# --- MakeMaker dynamic_bs section: + +BOOTSTRAP = + + +# --- MakeMaker dynamic_lib section: + + +# --- MakeMaker static section: + +## $(INST_PM) has been moved to the all: target. +## It remains here for awhile to allow for old usage: "make static" +static :: $(FIRST_MAKEFILE) $(INST_STATIC) + $(NOECHO) $(NOOP) + + +# --- MakeMaker static_lib section: + + +# --- MakeMaker manifypods section: + +POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--" +POD2MAN = $(POD2MAN_EXE) + + +manifypods : pure_all \ + lib/SQL/Abstract.pm + $(NOECHO) $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) \ + lib/SQL/Abstract.pm $(INST_MAN3DIR)\SQL.Abstract.$(MAN3EXT) + + + + +# --- MakeMaker processPL section: + + +# --- MakeMaker installbin section: + + +# --- MakeMaker subdirs section: + +# none + +# --- MakeMaker clean_subdirs section: +clean_subdirs : + $(NOECHO) $(NOOP) + + +# --- MakeMaker clean section: + +# Delete temporary files but do not touch installed files. We don't delete +# the Makefile here so a later make realclean still has a makefile to use. + +clean :: clean_subdirs + - $(RM_F) \ + *$(LIB_EXT) core \ + core.[0-9] core.[0-9][0-9] \ + $(BASEEXT).bso $(INST_ARCHAUTODIR)\extralibs.ld \ + pm_to_blib.ts core.[0-9][0-9][0-9][0-9] \ + $(BASEEXT).x $(BOOTSTRAP) \ + perl$(EXE_EXT) tmon.out \ + $(INST_ARCHAUTODIR)\extralibs.all *$(OBJ_EXT) \ + pm_to_blib blibdirs.ts \ + core.[0-9][0-9][0-9][0-9][0-9] *perl.core \ + core.*perl.*.? $(MAKE_APERL_FILE) \ + perl $(BASEEXT).def \ + core.[0-9][0-9][0-9] mon.out \ + lib$(BASEEXT).def perlmain.c \ + perl.exe so_locations \ + $(BASEEXT).exp + - $(RM_RF) \ + dll.exp dll.base \ + blib + - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) + + +# --- MakeMaker realclean_subdirs section: +realclean_subdirs : + $(NOECHO) $(NOOP) + + +# --- MakeMaker realclean section: +# Delete temporary files (via clean) and also delete dist files +realclean purge :: clean realclean_subdirs + - $(RM_F) \ + $(MAKEFILE_OLD) $(FIRST_MAKEFILE) + - $(RM_RF) \ + $(DISTVNAME) + + +# --- MakeMaker metafile section: +metafile : create_distdir + $(NOECHO) $(ECHO) Generating META.yml + $(NOECHO) $(ECHO) "--- #YAML:1.0" > META_new.yml + $(NOECHO) $(ECHO) "name: SQL-Abstract" >> META_new.yml + $(NOECHO) $(ECHO) "version: 1.49_01" >> META_new.yml + $(NOECHO) $(ECHO) "abstract: Generate SQL from Perl data structures" >> META_new.yml + $(NOECHO) $(ECHO) "license: ~" >> META_new.yml + $(NOECHO) $(ECHO) "author: " >> META_new.yml + $(NOECHO) $(ECHO) " - Nathan Wiger (nate@wiger.org)" >> META_new.yml + $(NOECHO) $(ECHO) "generated_by: ExtUtils::MakeMaker version 6.44" >> META_new.yml + $(NOECHO) $(ECHO) "distribution_type: module" >> META_new.yml + $(NOECHO) $(ECHO) "requires: " >> META_new.yml + $(NOECHO) $(ECHO) " List::Util: 0" >> META_new.yml + $(NOECHO) $(ECHO) "meta-spec:" >> META_new.yml + $(NOECHO) $(ECHO) " url: http://module-build.sourceforge.net/META-spec-v1.3.html" >> META_new.yml + $(NOECHO) $(ECHO) " version: 1.3" >> META_new.yml + -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml + + +# --- MakeMaker signature section: +signature : + cpansign -s + + +# --- MakeMaker dist_basics section: +distclean :: realclean distcheck + $(NOECHO) $(NOOP) + +distcheck : + $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck + +skipcheck : + $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck + +manifest : + $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest + +veryclean : realclean + $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old + + + +# --- MakeMaker dist_core section: + +dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) + $(NOECHO) $(ABSPERLRUN) -l -e "print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'\ + if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';" -- + +tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) + +uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu + +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) + +zipdist : $(DISTVNAME).zip + $(NOECHO) $(NOOP) + +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(POSTOP) + +shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(POSTOP) + + +# --- MakeMaker distdir section: +create_distdir : + $(RM_RF) $(DISTVNAME) + $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" + +distdir : create_distdir distmeta + $(NOECHO) $(NOOP) + + + +# --- MakeMaker dist_test section: +disttest : distdir + cd $(DISTVNAME) + $(ABSPERLRUN) Makefile.PL + $(MAKE) $(PASTHRU) + $(MAKE) test $(PASTHRU) + cd .. + + + +# --- MakeMaker dist_ci section: + +ci : + $(PERLRUN) "-MExtUtils::Manifest=maniread" \ + -e "@all = keys %{ maniread() };" \ + -e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \ + -e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});" + + +# --- MakeMaker distmeta section: +distmeta : create_distdir metafile + $(NOECHO) cd $(DISTVNAME) + $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e "eval { maniadd({q{META.yml} => q{Module meta-data (added by MakeMaker)}}) } \ + or print \"Could not add META.yml to MANIFEST: $${'@'}\n\"" -- + cd .. + + + +# --- MakeMaker distsignature section: +distsignature : create_distdir + $(NOECHO) cd $(DISTVNAME) + $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e "eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } \ + or print \"Could not add SIGNATURE to MANIFEST: $${'@'}\n\"" -- + cd .. + $(NOECHO) cd $(DISTVNAME) + $(TOUCH) SIGNATURE + cd .. + cd $(DISTVNAME) + cpansign -s + cd .. + + + +# --- MakeMaker install section: + +install :: all pure_install doc_install + $(NOECHO) $(NOOP) + +install_perl :: all pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + +install_site :: all pure_site_install doc_site_install + $(NOECHO) $(NOOP) + +install_vendor :: all pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +pure__install : pure_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +doc__install : doc_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +pure_perl_install :: + $(NOECHO) $(MOD_INSTALL) \ + read $(PERL_ARCHLIB)\auto\$(FULLEXT)\.packlist \ + write $(DESTINSTALLARCHLIB)\auto\$(FULLEXT)\.packlist \ + $(INST_LIB) $(DESTINSTALLPRIVLIB) \ + $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \ + $(INST_BIN) $(DESTINSTALLBIN) \ + $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + $(SITEARCHEXP)\auto\$(FULLEXT) + + +pure_site_install :: + $(NOECHO) $(MOD_INSTALL) \ + read $(SITEARCHEXP)\auto\$(FULLEXT)\.packlist \ + write $(DESTINSTALLSITEARCH)\auto\$(FULLEXT)\.packlist \ + $(INST_LIB) $(DESTINSTALLSITELIB) \ + $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \ + $(INST_BIN) $(DESTINSTALLSITEBIN) \ + $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + $(PERL_ARCHLIB)\auto\$(FULLEXT) + +pure_vendor_install :: + $(NOECHO) $(MOD_INSTALL) \ + read $(VENDORARCHEXP)\auto\$(FULLEXT)\.packlist \ + write $(DESTINSTALLVENDORARCH)\auto\$(FULLEXT)\.packlist \ + $(INST_LIB) $(DESTINSTALLVENDORLIB) \ + $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \ + $(INST_BIN) $(DESTINSTALLVENDORBIN) \ + $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) + +doc_perl_install :: + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLPRIVLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> $(DESTINSTALLARCHLIB)\perllocal.pod + +doc_site_install :: + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLSITELIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> $(DESTINSTALLARCHLIB)\perllocal.pod + +doc_vendor_install :: + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLVENDORLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> $(DESTINSTALLARCHLIB)\perllocal.pod + + +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + +uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) $(PERL_ARCHLIB)\auto\$(FULLEXT)\.packlist + +uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) $(SITEARCHEXP)\auto\$(FULLEXT)\.packlist + +uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) $(VENDORARCHEXP)\auto\$(FULLEXT)\.packlist + + +# --- MakeMaker force section: +# Phony target to force checking subdirectories. +FORCE : + $(NOECHO) $(NOOP) + + +# --- MakeMaker perldepend section: + + +# --- MakeMaker makefile section: +# We take a very conservative approach here, but it's worth it. +# We move Makefile to Makefile.old here to avoid gnu make looping. +$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) + $(NOECHO) $(ECHO) "Makefile out-of-date with respect to $?" + $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." + -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) + -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) + - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) + $(PERLRUN) Makefile.PL + $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" + $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" + false + + + +# --- MakeMaker staticmake section: + +# --- MakeMaker makeaperl section --- +MAP_TARGET = perl +FULLPERL = D:\Perl\bin\perl.exe + +$(MAP_TARGET) :: static $(MAKE_APERL_FILE) + $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ + +$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib + $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR= \ + MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 CCCDLFLAGS= + + +# --- MakeMaker test section: + +TEST_VERBOSE=0 +TEST_TYPE=test_$(LINKTYPE) +TEST_FILE = test.pl +TEST_FILES = t/*.t +TESTDB_SW = -d + +testdb :: testdb_$(LINKTYPE) + +test :: $(TEST_TYPE) subdirs-test + +subdirs-test :: + $(NOECHO) $(NOOP) + + +test_dynamic :: pure_all + $(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES) + +testdb_dynamic :: pure_all + $(FULLPERLRUN) $(TESTDB_SW) "-I$(INST_LIB)" "-I$(INST_ARCHLIB)" $(TEST_FILE) + +test_ : test_dynamic + +test_static :: test_dynamic +testdb_static :: testdb_dynamic + + +# --- MakeMaker ppd section: +# Creates a PPD (Perl Package Description) for a binary distribution. +ppd : + $(NOECHO) $(ECHO) "" > $(DISTNAME).ppd + $(NOECHO) $(ECHO) " $(DISTNAME)" >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " Generate SQL from Perl data structures" >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " Nathan Wiger (nate@wiger.org)" >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " " >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " " >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " " >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " " >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " " >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) " " >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) "" >> $(DISTNAME).ppd + + +# --- MakeMaker pm_to_blib section: + +pm_to_blib : $(TO_INST_PM) + $(NOECHO) $(ABSPERLRUN) -MExtUtils::Install -e "pm_to_blib({@ARGV}, '$(INST_LIB)\auto', '$(PM_FILTER)')" -- \ + lib/SQL/Abstract.pm blib\lib\SQL\Abstract.pm + $(NOECHO) $(TOUCH) pm_to_blib + + +# --- MakeMaker selfdocument section: + + +# --- MakeMaker postamble section: + + +# End. diff --git a/Makefile.PL b/Makefile.PL index ba45e0c..f1998fe 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,9 +3,11 @@ use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( - NAME => 'SQL::Abstract', - VERSION_FROM => 'lib/SQL/Abstract.pm', # finds $VERSION - PREREQ_PM => {}, # e.g., Module::Name => 1.1 + NAME => 'SQL::Abstract', + VERSION_FROM => 'lib/SQL/Abstract.pm', # finds $VERSION + PREREQ_PM => { + "List::Util" => 0 + }, # e.g., Module::Name => 1.1 ABSTRACT_FROM => 'lib/SQL/Abstract.pm', # retrieve abstract from module AUTHOR => 'Nathan Wiger (nate@wiger.org)', ); diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index ba798ac..bcc06f5 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -1,4 +1,1004 @@ -package SQL::Abstract; +package SQL::Abstract; # see doc at end of file + +# LDNOTE : this code is heavy refactoring from original SQLA. +# Several design decisions will need discussion during +# the test / diffusion / acceptance phase; those are marked with flag +# 'LDNOTE' (note by laurent.dami AT free.fr) + +use Carp; +use strict; +use warnings; +use List::Util qw/first/; + +#====================================================================== +# GLOBALS +#====================================================================== + +our $VERSION = '1.49_01'; + +our $AUTOLOAD; + +# special operators (-in, -between). May be extended/overridden by user. +# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation +my @BUILTIN_SPECIAL_OPS = ( + {regex => qr/^(not )?between$/i, handler => \&_where_field_BETWEEN}, + {regex => qr/^(not )?in$/i, handler => \&_where_field_IN}, +); + +#====================================================================== +# DEBUGGING AND ERROR REPORTING +#====================================================================== + +sub _debug { + return unless $_[0]->{debug}; shift; # a little faster + my $func = (caller(1))[3]; + warn "[$func] ", @_, "\n"; +} + +sub belch (@) { + my($func) = (caller(1))[3]; + carp "[$func] Warning: ", @_; +} + +sub puke (@) { + my($func) = (caller(1))[3]; + croak "[$func] Fatal: ", @_; +} + + +#====================================================================== +# NEW +#====================================================================== + +sub new { + my $self = shift; + my $class = ref($self) || $self; + my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; + + # choose our case by keeping an option around + delete $opt{case} if $opt{case} && $opt{case} ne 'lower'; + + # default logic for interpreting arrayrefs + $opt{logic} = uc $opt{logic} || 'OR'; + + # how to return bind vars + # LDNOTE: changed nwiger code : why this 'delete' ?? + # $opt{bindtype} ||= delete($opt{bind_type}) || 'normal'; + $opt{bindtype} ||= 'normal'; + + # default comparison is "=", but can be overridden + $opt{cmp} ||= '='; + + # try to recognize which are the 'equality' and 'unequality' ops + # (temporary quickfix, should go through a more seasoned API) + $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i; + $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i; + + # SQL booleans + $opt{sqltrue} ||= '1=1'; + $opt{sqlfalse} ||= '0=1'; + + # special operators + $opt{special_ops} ||= []; + push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS; + + return bless \%opt, $class; +} + + + +#====================================================================== +# INSERT methods +#====================================================================== + +sub insert { + my $self = shift; + my $table = $self->_table(shift); + my $data = shift || return; + + my $method = $self->_METHOD_FOR_refkind("_insert", $data); + my ($sql, @bind) = $self->$method($data); + $sql = join " ", $self->_sqlcase('insert into'), $table, $sql; + return wantarray ? ($sql, @bind) : $sql; +} + +sub _insert_HASHREF { # explicit list of fields and then values + my ($self, $data) = @_; + + my @fields = sort keys %$data; + + my ($sql, @bind); + { # get values (need temporary override of bindtype to avoid an error) + local $self->{bindtype} = 'normal'; + ($sql, @bind) = $self->_insert_ARRAYREF([@{$data}{@fields}]); + } + + # if necessary, transform values according to 'bindtype' + if ($self->{bindtype} eq 'columns') { + for my $i (0 .. $#fields) { + ($bind[$i]) = $self->_bindtype($fields[$i], $bind[$i]); + } + } + + # assemble SQL + $_ = $self->_quote($_) foreach @fields; + $sql = "( ".join(", ", @fields).") ".$sql; + + return ($sql, @bind); +} + +sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields) + my ($self, $data) = @_; + + # no names (arrayref) so can't generate bindtype + $self->{bindtype} ne 'columns' + or belch "can't do 'columns' bindtype when called with arrayref"; + + my (@values, @all_bind); + for my $v (@$data) { + + $self->_SWITCH_refkind($v, { + + ARRAYREF => sub { + if ($self->{array_datatypes}) { # if array datatype are activated + push @values, '?'; + } + else { # else literal SQL with bind + my ($sql, @bind) = @$v; + push @values, $sql; + push @all_bind, @bind; + } + }, + + ARRAYREFREF => sub { # literal SQL with bind + my ($sql, @bind) = @${$v}; + push @values, $sql; + push @all_bind, @bind; + }, + + # THINK : anything useful to do with a HASHREF ? + + SCALARREF => sub { # literal SQL without bind + push @values, $$v; + }, + + SCALAR_or_UNDEF => sub { + push @values, '?'; + push @all_bind, $v; + }, + + }); + + } + + my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )"; + return ($sql, @all_bind); +} + + +sub _insert_ARRAYREFREF { # literal SQL with bind + my ($self, $data) = @_; + return @${$data}; +} + + +sub _insert_SCALARREF { # literal SQL without bind + my ($self, $data) = @_; + + return ($$data); +} + + + +#====================================================================== +# UPDATE methods +#====================================================================== + + +sub update { + my $self = shift; + my $table = $self->_table(shift); + my $data = shift || return; + my $where = shift; + + # first build the 'SET' part of the sql statement + my (@set, @all_bind); + puke "Unsupported data type specified to \$sql->update" + unless ref $data eq 'HASH'; + + for my $k (sort keys %$data) { + my $v = $data->{$k}; + my $r = ref $v; + my $label = $self->_quote($k); + + $self->_SWITCH_refkind($v, { + ARRAYREF => sub { + if ($self->{array_datatypes}) { # array datatype + push @set, "$label = ?"; + push @all_bind, $self->_bindtype($k, $v); + } + else { # literal SQL with bind + my ($sql, @bind) = @$v; + push @set, "$label = $sql"; + push @all_bind, $self->_bindtype($k, @bind); + } + }, + ARRAYREFREF => sub { # literal SQL with bind + my ($sql, @bind) = @${$v}; + push @set, "$label = $sql"; + push @all_bind, $self->_bindtype($k, @bind); + }, + SCALARREF => sub { # literal SQL without bind + push @set, "$label = $$v"; + }, + SCALAR_or_UNDEF => sub { + push @set, "$label = ?"; + push @all_bind, $self->_bindtype($k, $v); + }, + }); + } + + # generate sql + my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ') + . join ', ', @set; + + if ($where) { + my($where_sql, @where_bind) = $self->where($where); + $sql .= $where_sql; + push @all_bind, @where_bind; + } + + return wantarray ? ($sql, @all_bind) : $sql; +} + + + + +#====================================================================== +# SELECT +#====================================================================== + + +sub select { + my $self = shift; + my $table = $self->_table(shift); + my $fields = shift || '*'; + my $where = shift; + my $order = shift; + + my($where_sql, @bind) = $self->where($where, $order); + + my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields + : $fields; + my $sql = join(' ', $self->_sqlcase('select'), $f, + $self->_sqlcase('from'), $table) + . $where_sql; + + return wantarray ? ($sql, @bind) : $sql; +} + +#====================================================================== +# DELETE +#====================================================================== + + +sub delete { + my $self = shift; + my $table = $self->_table(shift); + my $where = shift; + + + my($where_sql, @bind) = $self->where($where); + my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql; + + return wantarray ? ($sql, @bind) : $sql; +} + + +#====================================================================== +# WHERE: entry point +#====================================================================== + + + +# Finally, a separate routine just to handle WHERE clauses +sub where { + my ($self, $where, $order) = @_; + + # where ? + my ($sql, @bind) = $self->_recurse_where($where); + $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : ''; + + # order by? + if ($order) { + $sql .= $self->_order_by($order); + } + + return wantarray ? ($sql, @bind) : $sql; +} + + +sub _recurse_where { + my ($self, $where, $logic) = @_; + + # dispatch on appropriate method according to refkind of $where + my $method = $self->_METHOD_FOR_refkind("_where", $where); + $self->$method($where, $logic); +} + + + +#====================================================================== +# WHERE: top-level ARRAYREF +#====================================================================== + + +sub _where_ARRAYREF { + my ($self, $where, $logic) = @_; + + $logic = uc($logic || $self->{logic}); + $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic"; + + my @clauses = @$where; + + # if the array starts with [-and|or => ...], recurse with that logic + my $first = $clauses[0] || ''; + if ($first =~ /^-(and|or)/i) { + $logic = $1; + shift @clauses; + return $self->_where_ARRAYREF(\@clauses, $logic); + } + + #otherwise.. + my (@sql_clauses, @all_bind); + + # need to use while() so can shift() for pairs + while (my $el = shift @clauses) { + + # switch according to kind of $el and get corresponding ($sql, @bind) + my ($sql, @bind) = $self->_SWITCH_refkind($el, { + + # skip empty elements, otherwise get invalid trailing AND stuff + ARRAYREF => sub {$self->_recurse_where($el) if @$el}, + + HASHREF => sub {$self->_recurse_where($el, 'and') if %$el}, + # LDNOTE : previous SQLA code for hashrefs was creating a dirty + # side-effect: the first hashref within an array would change + # the global logic to 'AND'. So [ {cond1, cond2}, [cond3, cond4] ] + # was interpreted as "(cond1 AND cond2) OR (cond3 AND cond4)", + # whereas it should be "(cond1 AND cond2) OR (cond3 OR cond4)". + + SCALARREF => sub { ($$el); }, + + SCALAR => sub {# top-level arrayref with scalars, recurse in pairs + $self->_recurse_where({$el => shift(@clauses)})}, + + UNDEF => sub {puke "not supported : UNDEF in arrayref" }, + }); + + push @sql_clauses, $sql; + push @all_bind, @bind; + } + + return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind); +} + + + +#====================================================================== +# WHERE: top-level HASHREF +#====================================================================== + +sub _where_HASHREF { + my ($self, $where) = @_; + my (@sql_clauses, @all_bind); + + # LDNOTE : don't really know why we need to sort keys + for my $k (sort keys %$where) { + my $v = $where->{$k}; + + # ($k => $v) is either a special op or a regular hashpair + my ($sql, @bind) = ($k =~ /^-(.+)/) ? $self->_where_op_in_hash($1, $v) + : do { + my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v); + $self->$method($k, $v); + }; + + push @sql_clauses, $sql; + push @all_bind, @bind; + } + + return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind); +} + + +sub _where_op_in_hash { + my ($self, $op, $v) = @_; + + $op =~ /^(AND|OR|NEST)[_\d]*/i + or puke "unknown operator: -$op"; + $op = uc($1); # uppercase, remove trailing digits + $self->_debug("OP(-$op) within hashref, recursing..."); + + $self->_SWITCH_refkind($v, { + + ARRAYREF => sub { + # LDNOTE : should deprecate {-or => [...]} and {-and => [...]} + # because they are misleading; the only proper way would be + # -nest => [-or => ...], -nest => [-and ...] + return $self->_where_ARRAYREF($v, $op eq 'NEST' ? '' : $op); + }, + + HASHREF => sub { + if ($op eq 'OR') { + belch "-or => {...} should be -nest => [...]"; + return $self->_where_ARRAYREF([%$v], 'OR'); + } + else { # NEST | AND + return $self->_where_HASHREF($v); + } + }, + + SCALARREF => sub { # literal SQL + $op eq 'NEST' + or puke "-$op => \\\$scalar not supported, use -nest => ..."; + return ($$v); + }, + + ARRAYREFREF => sub { # literal SQL + $op eq 'NEST' + or puke "-$op => \\[..] not supported, use -nest => ..."; + return @{${$v}}; + }, + + SCALAR => sub { # permissively interpreted as SQL + $op eq 'NEST' + or puke "-$op => 'scalar' not supported, use -nest => \\'scalar'"; + belch "literal SQL should be -nest => \\'scalar' " + . "instead of -nest => 'scalar' "; + return ($v); + }, + + UNDEF => sub { + puke "-$op => undef not supported"; + }, + }); +} + + +sub _where_hashpair_ARRAYREF { + my ($self, $k, $v) = @_; + + if( @$v ) { + my @v = @$v; # need copy because of shift below + $self->_debug("ARRAY($k) means distribute over elements"); + + # put apart first element if it is an operator (-and, -or) + my $op = $v[0] =~ /^-/ ? shift @v : undef; + $self->_debug("OP($op) reinjected into the distributed array") if $op; + + my @distributed = map { {$k => $_} } @v; + unshift @distributed, $op if $op; + + return $self->_recurse_where(\@distributed); + } + else { + # LDNOTE : not sure of this one. What does "distribute over nothing" mean? + $self->_debug("empty ARRAY($k) means 0=1"); + return ($self->{sqlfalse}); + } +} + +sub _where_hashpair_HASHREF { + my ($self, $k, $v) = @_; + + my (@all_sql, @all_bind); + + for my $op (sort keys %$v) { + my $val = $v->{$op}; + + # put the operator in canonical form + $op =~ s/^-//; # remove initial dash + $op =~ tr/_/ /; # underscores become spaces + $op =~ s/^\s+//; # no initial space + $op =~ s/\s+$//; # no final space + $op =~ s/\s+/ /; # multiple spaces become one + + my ($sql, @bind); + + # CASE: special operators like -in or -between + my $special_op = first {$op =~ $_->{regex}} @{$self->{special_ops}}; + if ($special_op) { + ($sql, @bind) = $special_op->{handler}->($self, $k, $op, $val); + } + + # CASE: col => {op => \@vals} + elsif (ref $val eq 'ARRAY') { + ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val); + } + + # CASE: col => {op => undef} : sql "IS (NOT)? NULL" + elsif (! defined($val)) { + my $is = ($op =~ $self->{equality_op}) ? 'is' : + ($op =~ $self->{inequality_op}) ? 'is not' : + puke "unexpected operator '$op' with undef operand"; + $sql = $self->_quote($k) . $self->_sqlcase(" $is null"); + } + + # CASE: col => {op => $scalar} + else { + $sql = join ' ', $self->_convert($self->_quote($k)), + $self->_sqlcase($op), + $self->_convert('?'); + @bind = $self->_bindtype($k, $val); + } + + push @all_sql, $sql; + push @all_bind, @bind; + } + + return $self->_join_sql_clauses('and', \@all_sql, \@all_bind); +} + + + +sub _where_field_op_ARRAYREF { + my ($self, $k, $op, $vals) = @_; + + if(@$vals) { + $self->_debug("ARRAY($vals) means multiple elements: [ @$vals ]"); + + + + # LDNOTE : change the distribution logic when + # $op =~ $self->{inequality_op}, because of Morgan laws : + # with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate + # WHERE field != 22 OR field != 33 : the user probably means + # WHERE field != 22 AND field != 33. + my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR'; + + # distribute $op over each member of @$vals + return $self->_recurse_where([map { {$k => {$op, $_}} } @$vals], $logic); + + } + else { + # try to DWIM on equality operators + # LDNOTE : not 100% sure this is the correct thing to do ... + return ($self->{sqlfalse}) if $op =~ $self->{equality_op}; + return ($self->{sqltrue}) if $op =~ $self->{inequality_op}; + + # otherwise + puke "operator '$op' applied on an empty array (field '$k')"; + } +} + + +sub _where_hashpair_SCALARREF { + my ($self, $k, $v) = @_; + $self->_debug("SCALAR($k) means literal SQL: $$v"); + my $sql = $self->_quote($k) . " " . $$v; + return ($sql); +} + +sub _where_hashpair_ARRAYREFREF { + my ($self, $k, $v) = @_; + $self->_debug("REF($k) means literal SQL: @${$v}"); + my ($sql, @bind) = @${$v}; + $sql = $self->_quote($k) . " " . $sql; + @bind = $self->_bindtype($k, @bind); + return ($sql, @bind ); +} + +sub _where_hashpair_SCALAR { + my ($self, $k, $v) = @_; + $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v"); + my $sql = join ' ', $self->_convert($self->_quote($k)), + $self->_sqlcase($self->{cmp}), + $self->_convert('?'); + my @bind = $self->_bindtype($k, $v); + return ( $sql, @bind); +} + + +sub _where_hashpair_UNDEF { + my ($self, $k, $v) = @_; + $self->_debug("UNDEF($k) means IS NULL"); + my $sql = $self->_quote($k) . $self->_sqlcase(' is null'); + return ($sql); +} + +#====================================================================== +# WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF) +#====================================================================== + + +sub _where_SCALARREF { + my ($self, $where) = @_; + + # literal sql + $self->_debug("SCALAR(*top) means literal SQL: $$where"); + return ($$where); +} + + +sub _where_SCALAR { + my ($self, $where) = @_; + + # literal sql + $self->_debug("NOREF(*top) means literal SQL: $where"); + return ($where); +} + + +sub _where_UNDEF { + my ($self) = @_; + return (); +} + + +#====================================================================== +# WHERE: BUILTIN SPECIAL OPERATORS (-in, -between) +#====================================================================== + + +sub _where_field_BETWEEN { + my ($self, $k, $op, $vals) = @_; + + ref $vals eq 'ARRAY' && @$vals == 2 + or puke "special op 'between' requires an arrayref of two values"; + + my ($label) = $self->_convert($self->_quote($k)); + my ($placeholder) = $self->_convert('?'); + my $and = $self->_sqlcase('and'); + $op = $self->_sqlcase($op); + + my $sql = "( $label $op $placeholder $and $placeholder )"; + my @bind = $self->_bindtype($k, @$vals); + return ($sql, @bind) +} + + +sub _where_field_IN { + my ($self, $k, $op, $vals) = @_; + + # backwards compatibility : if scalar, force into an arrayref + $vals = [$vals] if defined $vals && ! ref $vals; + + ref $vals eq 'ARRAY' + or puke "special op 'in' requires an arrayref"; + + my ($label) = $self->_convert($self->_quote($k)); + my ($placeholder) = $self->_convert('?'); + my $and = $self->_sqlcase('and'); + $op = $self->_sqlcase($op); + + if (@$vals) { # nonempty list + my $placeholders = join ", ", (($placeholder) x @$vals); + my $sql = "$label $op ( $placeholders )"; + my @bind = $self->_bindtype($k, @$vals); + + return ($sql, @bind); + } + else { # empty list : some databases won't understand "IN ()", so DWIM + my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse}; + return ($sql); + } +} + + + + + + +#====================================================================== +# ORDER BY +#====================================================================== + +sub _order_by { + my ($self, $arg) = @_; + + # construct list of ordering instructions + my @order = $self->_SWITCH_refkind($arg, { + + ARRAYREF => sub { + map {$self->_SWITCH_refkind($_, { + SCALAR => sub {$self->_quote($_)}, + SCALARREF => sub {$$_}, # literal SQL, no quoting + HASHREF => sub {$self->_order_by_hash($_)} + }) } @$arg; + }, + + SCALAR => sub {$self->_quote($arg)}, + SCALARREF => sub {$$arg}, # literal SQL, no quoting + HASHREF => sub {$self->_order_by_hash($arg)}, + + }); + + # build SQL + my $order = join ', ', @order; + return $order ? $self->_sqlcase(' order by')." $order" : ''; +} + + +sub _order_by_hash { + my ($self, $hash) = @_; + + # get first pair in hash + my ($key, $val) = each %$hash; + + # check if one pair was found and no other pair in hash + $key && !(each %$hash) + or puke "hash passed to _order_by must have exactly one key (-desc or -asc)"; + + my ($order) = ($key =~ /^-(desc|asc)/i) + or puke "invalid key in _order_by hash : $key"; + + return $self->_quote($val) ." ". $self->_sqlcase($order); +} + + + +#====================================================================== +# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES) +#====================================================================== + +sub _table { + my $self = shift; + my $from = shift; + $self->_SWITCH_refkind($from, { + ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;}, + SCALAR => sub {$self->_quote($from)}, + SCALARREF => sub {$$from}, + ARRAYREFREF => sub {join ', ', @$from;}, + }); +} + + +#====================================================================== +# UTILITY FUNCTIONS +#====================================================================== + +sub _quote { + my $self = shift; + my $label = shift; + + $label or puke "can't quote an empty label"; + + # left and right quote characters + my ($ql, $qr, @other) = $self->_SWITCH_refkind($self->{quote_char}, { + SCALAR => sub {($self->{quote_char}, $self->{quote_char})}, + ARRAYREF => sub {@{$self->{quote_char}}}, + UNDEF => sub {()}, + }); + not @other + or puke "quote_char must be an arrayref of 2 values"; + + # no quoting if no quoting chars + $ql or return $label; + + # no quoting for literal SQL + return $$label if ref($label) eq 'SCALAR'; + + # separate table / column (if applicable) + my $sep = $self->{name_sep} || ''; + my @to_quote = $sep ? split /\Q$sep\E/, $label : ($label); + + # do the quoting, except for "*" or for `table`.* + my @quoted = map { $_ eq '*' ? $_: $ql.$_.$qr} @to_quote; + + # reassemble and return. + return join $sep, @quoted; +} + + +# Conversion, if applicable +sub _convert ($) { + my ($self, $arg) = @_; + +# LDNOTE : modified the previous implementation below because +# it was not consistent : the first "return" is always an array, +# the second "return" is context-dependent. Anyway, _convert +# seems always used with just a single argument, so make it a +# scalar function. +# return @_ unless $self->{convert}; +# my $conv = $self->_sqlcase($self->{convert}); +# my @ret = map { $conv.'('.$_.')' } @_; +# return wantarray ? @ret : $ret[0]; + if ($self->{convert}) { + my $conv = $self->_sqlcase($self->{convert}); + $arg = $conv.'('.$arg.')'; + } + return $arg; +} + +# And bindtype +sub _bindtype (@) { + my $self = shift; + my($col, @vals) = @_; + + #LDNOTE : changed original implementation below because it did not make + # sense when bindtype eq 'columns' and @vals > 1. +# return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals; + + return $self->{bindtype} eq 'columns' ? map {[$col, $_]} @vals : @vals; +} + +sub _join_sql_clauses { + my ($self, $logic, $clauses_aref, $bind_aref) = @_; + + if (@$clauses_aref > 1) { + my $join = " " . $self->_sqlcase($logic) . " "; + my $sql = '( ' . join($join, @$clauses_aref) . ' )'; + return ($sql, @$bind_aref); + } + elsif (@$clauses_aref) { + return ($clauses_aref->[0], @$bind_aref); # no parentheses + } + else { + return (); # if no SQL, ignore @$bind_aref + } +} + + +# Fix SQL case, if so requested +sub _sqlcase { + my $self = shift; + + # LDNOTE: if $self->{case} is true, then it contains 'lower', so we + # don't touch the argument ... crooked logic, but let's not change it! + return $self->{case} ? $_[0] : uc($_[0]); +} + + +#====================================================================== +# DISPATCHING FROM REFKIND +#====================================================================== + +sub _refkind { + my ($self, $data) = @_; + my $suffix = ''; + my $ref; + + # $suffix = 'REF' x (length of ref chain, i. e. \\[] is REFREFREF) + while (1) { + $suffix .= 'REF'; + $ref = ref $data; + last if $ref ne 'REF'; + $data = $$data; + } + + return $ref ? $ref.$suffix : + defined $data ? 'SCALAR' : + 'UNDEF'; +} + +sub _try_refkind { + my ($self, $data) = @_; + my @try = ($self->_refkind($data)); + push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF'; + push @try, 'FALLBACK'; + return @try; +} + +sub _METHOD_FOR_refkind { + my ($self, $meth_prefix, $data) = @_; + my $method = first {$_} map {$self->can($meth_prefix."_".$_)} + $self->_try_refkind($data) + or puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data); + return $method; +} + + +sub _SWITCH_refkind { + my ($self, $data, $dispatch_table) = @_; + + my $coderef = first {$_} map {$dispatch_table->{$_}} + $self->_try_refkind($data) + or puke "no dispatch entry for ".$self->_refkind($data); + $coderef->(); +} + + + + +#====================================================================== +# VALUES, GENERATE, AUTOLOAD +#====================================================================== + +# LDNOTE: original code from nwiger, didn't touch code in that section +# I feel the AUTOLOAD stuff should not be the default, it should +# only be activated on explicit demand by user. + +sub values { + my $self = shift; + my $data = shift || return; + puke "Argument to ", __PACKAGE__, "->values must be a \\%hash" + unless ref $data eq 'HASH'; + return map { $self->_bindtype($_, $data->{$_}) } sort keys %$data; +} + +sub generate { + my $self = shift; + + my(@sql, @sqlq, @sqlv); + + for (@_) { + my $ref = ref $_; + if ($ref eq 'HASH') { + for my $k (sort keys %$_) { + my $v = $_->{$k}; + my $r = ref $v; + my $label = $self->_quote($k); + if ($r eq 'ARRAY') { + # SQL included for values + my @bind = @$v; + my $sql = shift @bind; + push @sqlq, "$label = $sql"; + push @sqlv, $self->_bindtype($k, @bind); + } elsif ($r eq 'SCALAR') { + # embedded literal SQL + push @sqlq, "$label = $$v"; + } else { + push @sqlq, "$label = ?"; + push @sqlv, $self->_bindtype($k, $v); + } + } + push @sql, $self->_sqlcase('set'), join ', ', @sqlq; + } elsif ($ref eq 'ARRAY') { + # unlike insert(), assume these are ONLY the column names, i.e. for SQL + for my $v (@$_) { + my $r = ref $v; + if ($r eq 'ARRAY') { + my @val = @$v; + push @sqlq, shift @val; + push @sqlv, @val; + } elsif ($r eq 'SCALAR') { + # embedded literal SQL + push @sqlq, $$v; + } else { + push @sqlq, '?'; + push @sqlv, $v; + } + } + push @sql, '(' . join(', ', @sqlq) . ')'; + } elsif ($ref eq 'SCALAR') { + # literal SQL + push @sql, $$_; + } else { + # strings get case twiddled + push @sql, $self->_sqlcase($_); + } + } + + my $sql = join ' ', @sql; + + # this is pretty tricky + # if ask for an array, return ($stmt, @bind) + # otherwise, s/?/shift @sqlv/ to put it inline + if (wantarray) { + return ($sql, @sqlv); + } else { + 1 while $sql =~ s/\?/my $d = shift(@sqlv); + ref $d ? $d->[1] : $d/e; + return $sql; + } +} + + +sub DESTROY { 1 } + +sub AUTOLOAD { + # This allows us to check for a local, then _form, attr + my $self = shift; + my($name) = $AUTOLOAD =~ /.*::(.+)/; + return $self->generate($name, @_); +} + +1; + + + +__END__ =head1 NAME @@ -74,14 +1074,37 @@ These are then used directly in your DBI code: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); -In addition, you can apply SQL functions to elements of your C<%data> -by specifying an arrayref for the given hash value. For example, if -you need to execute the Oracle C function on a value, you -can say something like this: +=head2 Inserting and Updating Arrays + +If your database has array types (like for example Postgres), +activate the special option C<< array_datatypes => 1 >> +when creating the C object. +Then you may use an arrayref to insert and update database array types: + + my $sql = SQL::Abstract->new(array_datatypes => 1); + my %data = ( + planets => [qw/Mercury Venus Earth Mars/] + ); + + my($stmt, @bind) = $sql->insert('solar_system', \%data); + +This results in: + + $stmt = "INSERT INTO solar_system (planets) VALUES (?)" + + @bind = (['Mercury', 'Venus', 'Earth', 'Mars']); + + +=head2 Inserting and Updating SQL + +In order to apply SQL functions to elements of your C<%data> you may +specify a reference to an arrayref for the given hash value. For example, +if you need to execute the Oracle C function on a value, you can +say something like this: my %data = ( name => 'Bill', - date_entered => ["to_date(?,'MM/DD/YYYY')", "03/02/2003"], + date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"], ); The first value in the array is the actual SQL. Any other values are @@ -103,6 +1126,8 @@ the appropriately quirky SQL for you automatically. Usually you'll want to specify a WHERE clause for your UPDATE, though, which is where handling C<%where> hashes comes in handy... +=head2 Complex where statements + This module can generate pretty complicated WHERE statements easily. For example, simple C pairs are taken to mean equality, and if you want to see if a field is within a set @@ -138,182 +1163,8 @@ and a constructor you use first. The arguments are specified in a similar order to each function (table, then fields, then a where clause) to try and simplify things. -=cut - -use Carp; -use strict; - -our $VERSION = '1.23'; -#XXX don't understand this below, leaving it for someone else. did bump the $VERSION --groditi -our $REVISION = '$Id$'; -our $AUTOLOAD; - -# Fix SQL case, if so requested -sub _sqlcase { - my $self = shift; - return $self->{case} ? $_[0] : uc($_[0]); -} - -# Anon copies of arrays/hashes -# Based on deep_copy example by merlyn -# http://www.stonehenge.com/merlyn/UnixReview/col30.html -sub _anoncopy { - my $orig = shift; - return (ref $orig eq 'HASH') ? +{map { $_ => _anoncopy($orig->{$_}) } keys %$orig} - : (ref $orig eq 'ARRAY') ? [map _anoncopy($_), @$orig] - : $orig; -} - -# Debug -sub _debug { - return unless $_[0]->{debug}; shift; # a little faster - my $func = (caller(1))[3]; - warn "[$func] ", @_, "\n"; -} - -sub belch (@) { - my($func) = (caller(1))[3]; - carp "[$func] Warning: ", @_; -} - -sub puke (@) { - my($func) = (caller(1))[3]; - croak "[$func] Fatal: ", @_; -} - -# Utility functions -sub _table { - my $self = shift; - my $from = shift; - if (ref $from eq 'ARRAY') { - return $self->_recurse_from(@$from); - } elsif (ref $from eq 'HASH') { - return $self->_make_as($from); - } else { - return $self->_quote($from); - } -} - -sub _recurse_from { - my ($self, $from, @join) = @_; - my @sqlf; - push(@sqlf, $self->_make_as($from)); - foreach my $j (@join) { - push @sqlf, ', ' . $self->_quote($j) and next unless ref $j; - push @sqlf, ', ' . $$j and next if ref $j eq 'SCALAR'; - my ($to, $on) = @$j; - - # check whether a join type exists - my $join_clause = ''; - my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to; - if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) { - $join_clause = $self->_sqlcase(' '.($to_jt->{-join_type}).' JOIN '); - } else { - $join_clause = $self->_sqlcase(' JOIN '); - } - push(@sqlf, $join_clause); - - if (ref $to eq 'ARRAY') { - push(@sqlf, '(', $self->_recurse_from(@$to), ')'); - } else { - push(@sqlf, $self->_make_as($to)); - } - push(@sqlf, $self->_sqlcase(' ON '), $self->_join_condition($on)); - } - return join('', @sqlf); -} -sub _make_as { - my ($self, $from) = @_; - return $self->_quote($from) unless ref $from; - return $$from if ref $from eq 'SCALAR'; - return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) } - reverse each %{$self->_skip_options($from)}); -} -sub _skip_options { - my ($self, $hash) = @_; - my $clean_hash = {}; - $clean_hash->{$_} = $hash->{$_} - for grep {!/^-/} keys %$hash; - return $clean_hash; -} - -sub _join_condition { - my ($self, $cond) = @_; - if (ref $cond eq 'HASH') { - my %j; - for (keys %$cond) { - my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x; - }; - return $self->_recurse_where(\%j); - } elsif (ref $cond eq 'ARRAY') { - return join(' OR ', map { $self->_join_condition($_) } @$cond); - } else { - die "Can't handle this yet!"; - } -} - - -sub _quote { - my $self = shift; - my $label = shift; - - return '' unless defined $label; - - return $label - if $label eq '*'; - - return $$label if ref($label) eq 'SCALAR'; - - return $label unless $self->{quote_char}; - - if (ref $self->{quote_char} eq "ARRAY") { - - return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1] - if !defined $self->{name_sep}; - - my $sep = $self->{name_sep}; - return join($self->{name_sep}, - map { $_ eq '*' - ? $_ - : $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] } - split( /\Q$sep\E/, $label ) ); - } - - - return $self->{quote_char} . $label . $self->{quote_char} - if !defined $self->{name_sep}; - - return join $self->{name_sep}, - map { $_ eq '*' ? $_ : $self->{quote_char} . $_ . $self->{quote_char} } - split /\Q$self->{name_sep}\E/, $label; -} - -# Conversion, if applicable -sub _convert ($) { - my $self = shift; - return @_ unless $self->{convert}; - my $conv = $self->_sqlcase($self->{convert}); - my @ret = map { $conv.'('.$_.')' } @_; - return wantarray ? @ret : $ret[0]; -} - -# And bindtype -sub _bindtype (@) { - my $self = shift; - my($col,@val) = @_; - return $self->{bindtype} eq 'columns' ? [ @_ ] : @val; -} - -# Modified -logic or -nest -sub _modlogic ($) { - my $self = shift; - my $sym = @_ ? lc(shift) : $self->{logic}; - $sym =~ tr/_/ /; - $sym = $self->{logic} if $sym eq 'nest'; - return $self->_sqlcase($sym); # override join -} =head2 new(option => 'value') @@ -330,6 +1181,8 @@ default SQL is generated in "textbook" case meaning something like: SELECT a_field FROM a_table WHERE some_field LIKE '%someval%' +Any setting other than 'lower' is ignored. + =item cmp This determines what the default comparison operator is. By default @@ -349,6 +1202,11 @@ C to C you would get SQL such as: You can also override the comparsion on an individual basis - see the huge section on L at the bottom. +=item sqltrue, sqlfalse + +Expressions for inserting boolean values within SQL statements. +By default these are C<1=1> and C<1=0>. + =item logic This determines the default logical operator for multiple WHERE @@ -373,6 +1231,14 @@ Which will change the above C to: WHERE event_date >= '2/13/99' AND event_date <= '4/24/03' +The logic can also be changed locally by inserting +an extra first element in the array : + + @where = (-and => event_date => {'>=', '2/13/99'}, + event_date => {'<=', '4/24/03'} ); + +See the L section for explanations. + =item convert This will automatically convert comparisons using the specified SQL @@ -447,8 +1313,15 @@ the character C<`>, to generate SQL like this: SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%' -This is useful if you have tables or columns that are reserved words -in your database's SQL dialect. +Alternatively, you can supply an array ref of two items, the first being the left +hand quote character, and the second the right hand quote character. For +example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes +that generates SQL like this: + + SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%' + +Quoting is useful if you have tables or columns names that are reserved +words in your database's SQL dialect. =item name_sep @@ -458,200 +1331,94 @@ so that tables and column names can be individually quoted like this: SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1 -=back - -=cut +=item array_datatypes -sub new { - my $self = shift; - my $class = ref($self) || $self; - my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; +When this option is true, arrayrefs in INSERT or UPDATE are +interpreted as array datatypes and are passed directly +to the DBI layer. +When this option is false, arrayrefs are interpreted +as literal SQL, just like refs to arrayrefs +(but this behavior is for backwards compatibility; when writing +new queries, use the "reference to arrayref" syntax +for literal SQL). - # choose our case by keeping an option around - delete $opt{case} if $opt{case} && $opt{case} ne 'lower'; - # override logical operator - $opt{logic} = uc $opt{logic} if $opt{logic}; +=item special_ops - # how to return bind vars - $opt{bindtype} ||= delete($opt{bind_type}) || 'normal'; +Takes a reference to a list of "special operators" +to extend the syntax understood by L. +See section L for details. - # default comparison is "=", but can be overridden - $opt{cmp} ||= '='; - # default quotation character around tables/columns - $opt{quote_char} ||= ''; - return bless \%opt, $class; -} +=back =head2 insert($table, \@values || \%fieldvals) This is the simplest function. You simply give it a table name and either an arrayref of values or hashref of field/value pairs. It returns an SQL INSERT statement and a list of bind values. - -=cut - -sub insert { - my $self = shift; - my $table = $self->_table(shift); - my $data = shift || return; - - my $sql = $self->_sqlcase('insert into') . " $table "; - my(@sqlf, @sqlv, @sqlq) = (); - - my $ref = ref $data; - if ($ref eq 'HASH') { - for my $k (sort keys %$data) { - my $v = $data->{$k}; - my $r = ref $v; - # named fields, so must save names in order - push @sqlf, $self->_quote($k); - if ($r eq 'ARRAY') { - # SQL included for values - my @val = @$v; - push @sqlq, shift @val; - push @sqlv, $self->_bindtype($k, @val); - } elsif ($r eq 'SCALAR') { - # embedded literal SQL - push @sqlq, $$v; - } else { - push @sqlq, '?'; - push @sqlv, $self->_bindtype($k, $v); - } - } - $sql .= '(' . join(', ', @sqlf) .') '. $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')'; - } elsif ($ref eq 'ARRAY') { - # just generate values(?,?) part - # no names (arrayref) so can't generate bindtype - carp "Warning: ",__PACKAGE__,"->insert called with arrayref when bindtype set" - if $self->{bindtype} ne 'normal'; - for my $v (@$data) { - my $r = ref $v; - if ($r eq 'ARRAY') { - my @val = @$v; - push @sqlq, shift @val; - push @sqlv, @val; - } elsif ($r eq 'SCALAR') { - # embedded literal SQL - push @sqlq, $$v; - } else { - push @sqlq, '?'; - push @sqlv, $v; - } - } - $sql .= $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')'; - } elsif ($ref eq 'SCALAR') { - # literal SQL - $sql .= $$data; - } else { - puke "Unsupported data type specified to \$sql->insert"; - } - - return wantarray ? ($sql, @sqlv) : $sql; -} +See the sections on L and +L for information on how to insert +with those data types. =head2 update($table, \%fieldvals, \%where) This takes a table, hashref of field/value pairs, and an optional hashref L. It returns an SQL UPDATE function and a list of bind values. +See the sections on L and +L for information on how to insert +with those data types. -=cut - -sub update { - my $self = shift; - my $table = $self->_table(shift); - my $data = shift || return; - my $where = shift; +=head2 select($source, $fields, $where, $order) - my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set '); - my(@sqlf, @sqlv) = (); - - puke "Unsupported data type specified to \$sql->update" - unless ref $data eq 'HASH'; +This returns a SQL SELECT statement and associated list of bind values, as +specified by the arguments : - for my $k (sort keys %$data) { - my $v = $data->{$k}; - my $r = ref $v; - my $label = $self->_quote($k); - if ($r eq 'ARRAY') { - # SQL included for values - my @bind = @$v; - my $sql = shift @bind; - push @sqlf, "$label = $sql"; - push @sqlv, $self->_bindtype($k, @bind); - } elsif ($r eq 'SCALAR') { - # embedded literal SQL - push @sqlf, "$label = $$v"; - } else { - push @sqlf, "$label = ?"; - push @sqlv, $self->_bindtype($k, $v); - } - } +=over - $sql .= join ', ', @sqlf; +=item $source - if ($where) { - my($wsql, @wval) = $self->where($where); - $sql .= $wsql; - push @sqlv, @wval; - } +Specification of the 'FROM' part of the statement. +The argument can be either a plain scalar (interpreted as a table +name, will be quoted), or an arrayref (interpreted as a list +of table names, joined by commas, quoted), or a scalarref +(literal table name, not quoted), or a ref to an arrayref +(list of literal table names, joined by commas, not quoted). - return wantarray ? ($sql, @sqlv) : $sql; -} +=item $fields -=head2 select($table, \@fields, \%where, \@order) +Specification of the list of fields to retrieve from +the source. +The argument can be either an arrayref (interpreted as a list +of field names, will be joined by commas and quoted), or a +plain scalar (literal SQL, not quoted). +Please observe that this API is not as flexible as for +the first argument <$table>, for backwards compatibility reasons. -This takes a table, arrayref of fields (or '*'), optional hashref -L, and optional array or hash ref L, and returns the -corresponding SQL SELECT statement and list of bind values. +=item $where -=cut +Optional argument to specify the WHERE part of the query. +The argument is most often a hashref, but can also be +an arrayref or plain scalar -- +see section L for details. -sub select { - my $self = shift; - my $table = $self->_table(shift); - my $fields = shift || '*'; - my $where = shift; - my $order = shift; +=item $order - my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields : $fields; - my $sql = join ' ', $self->_sqlcase('select'), $f, $self->_sqlcase('from'), $table; +Optional argument to specify the ORDER BY part of the query. +The argument can be a scalar, a hashref or an arrayref +-- see section L +for details. - my(@sqlf, @sqlv) = (); - my($wsql, @wval) = $self->where($where, $order); - $sql .= $wsql; - push @sqlv, @wval; +=back - return wantarray ? ($sql, @sqlv) : $sql; -} =head2 delete($table, \%where) This takes a table name and optional hashref L. It returns an SQL DELETE statement and list of bind values. -=cut - -sub delete { - my $self = shift; - my $table = $self->_table(shift); - my $where = shift; - - my $sql = $self->_sqlcase('delete from') . " $table"; - my(@sqlf, @sqlv) = (); - - if ($where) { - my($wsql, @wval) = $self->where($where); - $sql .= $wsql; - push @sqlv, @wval; - } - - return wantarray ? ($sql, @sqlv) : $sql; -} - =head2 where(\%where, \@order) This is used to generate just the WHERE clause. For example, @@ -660,247 +1427,6 @@ rest of your SQL is going to look like, but want an easy way to produce a WHERE clause, use this. It returns an SQL WHERE clause and list of bind values. -=cut - -# Finally, a separate routine just to handle WHERE clauses -sub where { - my $self = shift; - my $where = shift; - my $order = shift; - - # Need a separate routine to properly wrap w/ "where" - my $sql = ''; - my @ret = $self->_recurse_where($where); - if (@ret) { - my $wh = shift @ret; - $sql .= $self->_sqlcase(' where ') . $wh if $wh; - } - - # order by? - if ($order) { - $sql .= $self->_order_by($order); - } - - return wantarray ? ($sql, @ret) : $sql; -} - - -sub _recurse_where { - local $^W = 0; # really, you've gotta be fucking kidding me - my $self = shift; - my $where = _anoncopy(shift); # prevent destroying original - my $ref = ref $where || ''; - my $join = shift || $self->{logic} || - ($ref eq 'ARRAY' ? $self->_sqlcase('or') : $self->_sqlcase('and')); - - # For assembling SQL fields and values - my(@sqlf, @sqlv) = (); - - # If an arrayref, then we join each element - if ($ref eq 'ARRAY') { - # need to use while() so can shift() for arrays - my $subjoin; - while (my $el = shift @$where) { - - # skip empty elements, otherwise get invalid trailing AND stuff - if (my $ref2 = ref $el) { - if ($ref2 eq 'ARRAY') { - next unless @$el; - } elsif ($ref2 eq 'HASH') { - next unless %$el; - $subjoin ||= $self->_sqlcase('and'); - } elsif ($ref2 eq 'SCALAR') { - # literal SQL - push @sqlf, $$el; - next; - } - $self->_debug("$ref2(*top) means join with $subjoin"); - } else { - # top-level arrayref with scalars, recurse in pairs - $self->_debug("NOREF(*top) means join with $subjoin"); - $el = {$el => shift(@$where)}; - } - my @ret = $self->_recurse_where($el, $subjoin); - push @sqlf, shift @ret; - push @sqlv, @ret; - } - } - elsif ($ref eq 'HASH') { - # Note: during recursion, the last element will always be a hashref, - # since it needs to point a column => value. So this be the end. - for my $k (sort keys %$where) { - my $v = $where->{$k}; - my $label = $self->_quote($k); - - if ($k =~ /^-(\D+)/) { - # special nesting, like -and, -or, -nest, so shift over - my $subjoin = $self->_modlogic($1); - $self->_debug("OP(-$1) means special logic ($subjoin), recursing..."); - my @ret = $self->_recurse_where($v, $subjoin); - push @sqlf, shift @ret; - push @sqlv, @ret; - } elsif (! defined($v)) { - # undef = null - $self->_debug("UNDEF($k) means IS NULL"); - push @sqlf, $label . $self->_sqlcase(' is null'); - } elsif (ref $v eq 'ARRAY') { - if( @$v ) { - my @v = @$v; - # multiple elements: multiple options - $self->_debug("ARRAY($k) means multiple elements: [ @v ]"); - - # special nesting, like -and, -or, -nest, so shift over - my $subjoin = $self->_sqlcase('or'); - if ($v[0] =~ /^-(\D+)/) { - $subjoin = $self->_modlogic($1); # override subjoin - $self->_debug("OP(-$1) means special logic ($subjoin), shifting..."); - shift @v; - } - - # map into an array of hashrefs and recurse - my @ret = $self->_recurse_where([map { {$k => $_} } @v], $subjoin); - - # push results into our structure - push @sqlf, shift @ret; - push @sqlv, @ret; - } else { - $self->_debug("empty ARRAY($k) means 0=1"); - push @sqlf, '0=1'; - } - } elsif (ref $v eq 'HASH') { - # modified operator { '!=', 'completed' } - for my $f (sort keys %$v) { - my $x = $v->{$f}; - - # do the right thing for single -in values - $x = [$x] if ($f =~ /^-?\s*(not[\s_]+)?in\s*$/i && ref $x ne 'ARRAY'); - - $self->_debug("HASH($k) means modified operator: { $f }"); - - # check for the operator being "IN" or "BETWEEN" or whatever - if (ref $x eq 'ARRAY') { - if ($f =~ /^-?\s*(not[\s_]+)?(in|between)\s*$/i) { - my $u = $self->_modlogic($1 . $2); - $self->_debug("HASH($f => $x) uses special operator: [ $u ]"); - if ($u =~ /between/i) { - # SQL sucks - # Throw an exception if you try to use between with - # anything other than 2 values - $self->puke("You need two values to use between") unless @$x == 2; - push @sqlf, join ' ', $self->_convert($label), $u, $self->_convert('?'), - $self->_sqlcase('and'), $self->_convert('?'); - } elsif (@$x) { - # DWIM for empty arrayrefs - push @sqlf, join ' ', $self->_convert($label), $u, '(', - join(', ', map { $self->_convert('?') } @$x), - ')'; - } elsif(@$x == 0){ - # Empty IN defaults to 0=1 and empty NOT IN to 1=1 - push(@sqlf, ($u =~ /not/i ? "1=1" : "0=1")); - } - push @sqlv, $self->_bindtype($k, @$x); - } elsif(@$x) { - # multiple elements: multiple options - $self->_debug("ARRAY($x) means multiple elements: [ @$x ]"); - # map into an array of hashrefs and recurse - my @ret = $self->_recurse_where([map { {$k => {$f, $_}} } @$x]); - - # push results into our structure - push @sqlf, shift @ret; - push @sqlv, @ret; - } else { - #DTRT for $op => [] - # I feel like <= and >= should resolve to 0=1 but I am not sure. - if($f eq '='){ - push @sqlf, '0=1'; - } elsif( $f eq '!='){ - push @sqlf, '1=1'; - } else { - $self->puke("Can not generate SQL for '${f}' comparison of '${k}' using empty array"); - } - } - } elsif (! defined($x)) { - # undef = NOT null - my $not = ($f eq '!=' || $f eq 'not like') ? ' not' : ''; - push @sqlf, $label . $self->_sqlcase(" is$not null"); - } else { - # regular ol' value - $f =~ s/^-//; # strip leading -like => - $f =~ s/_/ /; # _ => " " - push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($f), $self->_convert('?'); - push @sqlv, $self->_bindtype($k, $x); - } - } - } elsif (ref $v eq 'SCALAR') { - # literal SQL - $self->_debug("SCALAR($k) means literal SQL: $$v"); - push @sqlf, "$label $$v"; - } else { - # standard key => val - $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v"); - push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($self->{cmp}), $self->_convert('?'); - push @sqlv, $self->_bindtype($k, $v); - } - } - } - elsif ($ref eq 'SCALAR') { - # literal sql - $self->_debug("SCALAR(*top) means literal SQL: $$where"); - push @sqlf, $$where; - } - elsif (defined $where) { - # literal sql - $self->_debug("NOREF(*top) means literal SQL: $where"); - push @sqlf, $where; - } - - # assemble and return sql - my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : ''; - return wantarray ? ($wsql, @sqlv) : $wsql; -} - -sub _order_by { - my $self = shift; - my $ref = ref $_[0] || ''; - - my $_order_hash = sub { - local *__ANON__ = '_order_by_hash'; - my ($col, $order); - my $hash = shift; # $_ was failing in some cases for me --groditi - if ( $col = $hash->{'-desc'} ) { - $order = 'DESC' - } elsif ( $col = $hash->{'-asc'} ) { - $order = 'ASC'; - } else { - puke "Hash must have a key of '-desc' or '-asc' for ORDER BY"; - } - return $self->_quote($col) . " $order"; - - }; - - my @vals; - if ($ref eq 'ARRAY') { - foreach (@{ $_[0] }) { - my $ref = ref $_; - if (!$ref || $ref eq 'SCALAR') { - push @vals, $self->_quote($_); - } elsif ($ref eq 'HASH') { - push @vals, $_order_hash->($_); - } else { - puke "Unsupported nested data struct $ref for ORDER BY"; - } - } - } elsif ($ref eq 'HASH') { - push @vals, $_order_hash->($_[0]); - } elsif (!$ref || $ref eq 'SCALAR') { - push @vals, $self->_quote($_[0]); - } else { - puke "Unsupported data struct $ref for ORDER BY"; - } - - my $val = join ', ', @vals; - return $val ? $self->_sqlcase(' order by')." $val" : ''; -} =head2 values(\%data) @@ -909,16 +1435,6 @@ order that would be returned from any of the other above queries. Using this allows you to markedly speed up your queries if you are affecting lots of rows. See below under the L section. -=cut - -sub values { - my $self = shift; - my $data = shift || return; - puke "Argument to ", __PACKAGE__, "->values must be a \\%hash" - unless ref $data eq 'HASH'; - return map { $self->_bindtype($_, $data->{$_}) } sort keys %$data; -} - =head2 generate($any, 'number', $of, \@data, $struct, \%types) Warning: This is an experimental method and subject to change. @@ -952,89 +1468,13 @@ Might give you: You get the idea. Strings get their case twiddled, but everything else remains verbatim. -=cut - -sub generate { - my $self = shift; - - my(@sql, @sqlq, @sqlv); - - for (@_) { - my $ref = ref $_; - if ($ref eq 'HASH') { - for my $k (sort keys %$_) { - my $v = $_->{$k}; - my $r = ref $v; - my $label = $self->_quote($k); - if ($r eq 'ARRAY') { - # SQL included for values - my @bind = @$v; - my $sql = shift @bind; - push @sqlq, "$label = $sql"; - push @sqlv, $self->_bindtype($k, @bind); - } elsif ($r eq 'SCALAR') { - # embedded literal SQL - push @sqlq, "$label = $$v"; - } else { - push @sqlq, "$label = ?"; - push @sqlv, $self->_bindtype($k, $v); - } - } - push @sql, $self->_sqlcase('set'), join ', ', @sqlq; - } elsif ($ref eq 'ARRAY') { - # unlike insert(), assume these are ONLY the column names, i.e. for SQL - for my $v (@$_) { - my $r = ref $v; - if ($r eq 'ARRAY') { - my @val = @$v; - push @sqlq, shift @val; - push @sqlv, @val; - } elsif ($r eq 'SCALAR') { - # embedded literal SQL - push @sqlq, $$v; - } else { - push @sqlq, '?'; - push @sqlv, $v; - } - } - push @sql, '(' . join(', ', @sqlq) . ')'; - } elsif ($ref eq 'SCALAR') { - # literal SQL - push @sql, $$_; - } else { - # strings get case twiddled - push @sql, $self->_sqlcase($_); - } - } - - my $sql = join ' ', @sql; - - # this is pretty tricky - # if ask for an array, return ($stmt, @bind) - # otherwise, s/?/shift @sqlv/ to put it inline - if (wantarray) { - return ($sql, @sqlv); - } else { - 1 while $sql =~ s/\?/my $d = shift(@sqlv); - ref $d ? $d->[1] : $d/e; - return $sql; - } -} - -sub DESTROY { 1 } -sub AUTOLOAD { - # This allows us to check for a local, then _form, attr - my $self = shift; - my($name) = $AUTOLOAD =~ /.*::(.+)/; - return $self->generate($name, @_); -} -1; -__END__ =head1 WHERE CLAUSES +=head2 Introduction + This module uses a variation on the idea from L. It is B, repeat I 100% compatible. B hash shown, it is assumed you used: However, note that the C<%where> hash can be used directly in any of the other functions as well, as described above. +=head2 Key-value pairs + So, let's get started. To begin, a simple hash: my %where = ( @@ -1074,9 +1516,11 @@ This simple code will create the following: $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )"; @bind = ('nwiger', 'assigned', 'in-progress', 'pending'); -Please note that an empty arrayref will be considered a logical false and +An empty arrayref will be considered a logical false and will generate 0=1. +=head2 Key-value pairs + If you want to specify a different type of operator for your comparison, you can use a hashref for a given column: @@ -1094,15 +1538,22 @@ To test against multiple values, just enclose the values in an arrayref: status => { '!=', ['assigned', 'in-progress', 'pending'] }; -An empty arrayref will try to Do The Right Thing for the operators '=', '!=', -'-in' '-not_in', but will throw an exception for everything else. - Which would give you: - "WHERE status != ? OR status != ? OR status != ?" + "WHERE status != ? AND status != ? AND status != ?" -But, this is probably not what you want in this case (look at it). So -the hashref can also contain multiple pairs, in which case it is expanded +Notice that since the operator was recognized as being a 'negative' +operator, the arrayref was interpreted with 'AND' logic (because +of Morgan's laws). By contrast, the reverse + + status => { '=', ['assigned', 'in-progress', 'pending'] }; + +would generate : + + "WHERE status = ? OR status = ? OR status = ?" + + +The hashref can also contain multiple pairs, in which case it is expanded into an C of its elements: my %where = ( @@ -1119,6 +1570,7 @@ into an C of its elements: $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?"; @bind = ('nwiger', 'completed', 'pending%'); + To get an OR instead, you can combine it with the arrayref idea: my %where => ( @@ -1131,7 +1583,11 @@ Which would generate: $stmt = "WHERE user = ? AND priority = ? OR priority != ?"; @bind = ('nwiger', '2', '1'); -However, there is a subtle trap if you want to say something like + +=head2 Logic and nesting operators + +In the example above, +there is a subtle trap if you want to say something like this (notice the C): WHERE priority != ? AND priority != ? @@ -1143,7 +1599,9 @@ Because, in Perl you I do this: As the second C key will obliterate the first. The solution is to use the special C<-modifier> form inside an arrayref: - priority => [ -and => {'!=', 2}, {'!=', 1} ] + priority => [ -and => {'!=', 2}, + {'!=', 1} ] + Normally, these would be joined by C, but the modifier tells it to use C instead. (Hint: You can use this in conjunction with the @@ -1179,6 +1637,8 @@ You would do: -nest => [ workhrs => {'>', 20}, geo => 'ASIA' ], ); +=head2 Special operators : IN, BETWEEN, etc. + You can also use the hashref format to compare a list of fields using the C comparison operator, by specifying the list as an arrayref: @@ -1192,8 +1652,11 @@ Which would generate: $stmt = "WHERE status = ? AND reportid IN (?,?,?)"; @bind = ('completed', '567', '2335', '2'); -You can use this same format to use other grouping functions, such -as C, C, and so forth. For example: +The reverse operator C<-not_in> generates SQL C and is used in +the same way. + +Another pair of operators is C<-between> and C<-not_between>, +used with an arrayref of two values: my %where = ( user => 'nwiger', @@ -1206,6 +1669,11 @@ Would give you: WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? ) +These are the two builtin "special operators"; but the +list can be expanded : see section L below. + +=head2 Nested conditions + So far, we've seen how multiple conditions are joined with a top-level C. We can change this by putting the different conditions we want in hashes and then putting those hashes in an array. For example: @@ -1246,6 +1714,8 @@ That would yield: ( ( workhrs > ? AND geo = ? ) OR ( workhrs < ? AND geo = ? ) ) ) +=head2 Literal SQL + Finally, sometimes only literal SQL will do. If you want to include literal SQL verbatim, you can specify it as a scalar reference, namely: @@ -1271,8 +1741,123 @@ with this: requestor => { '!=', undef }, ); + TMTOWTDI. +Conditions on boolean columns can be expressed in the +same way, passing a reference to an empty string : + + my %where = ( + priority => { '<', 2 }, + is_ready => \""; + ); + +which yields + + $stmt = "WHERE priority < ? AND is_ready"; + @bind = ('2'); + + +=head2 Literal SQL with placeholders and bind values (subqueries) + +If the literal SQL to be inserted has placeholders and bind values, +use a reference to an arrayref (yes this is a double reference -- +not so common, but perfectly legal Perl). For example, to find a date +in Postgres you can use something like this: + + my %where = ( + date_column => \[q/= date '2008-09-30' - ?::integer/, 10/] + ) + +This would create: + + $stmt = "WHERE ( date_column = date \'2008-09-30\' - ?::integer )" + @bind = ('10'); + + +Literal SQL is especially useful for nesting parenthesized clauses in the +main SQL query. Here is a first example : + + my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", + 100, "foo%"); + my %where = ( + foo => 1234, + bar => \["IN ($sub_stmt)" => @sub_bind], + ); + +This yields : + + $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1 + WHERE c2 < ? AND c3 LIKE ?))"; + @bind = (1234, 100, "foo%"); + +Other subquery operators, like for example C<"E ALL"> or C<"NOT IN">, +are expressed in the same way. Of course the C<$sub_stmt> and +its associated bind values can be generated through a former call +to C : + + my ($sub_stmt, @sub_bind) + = $sql->select("t1", "c1", {c2 => {"<" => 100}, + c3 => {-like => "foo%"}}); + my %where = ( + foo => 1234, + bar => \["> ALL ($sub_stmt)" => @sub_bind], + ); + +In the examples above, the subquery was used as an operator on a column; +but the same principle also applies for a clause within the main C<%where> +hash, like an EXISTS subquery : + + my ($sub_stmt, @sub_bind) + = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); + my %where = ( + foo => 1234, + -nest => \["EXISTS ($sub_stmt)" => @sub_bind], + ); + +which yields + + $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1 + WHERE c1 = ? AND c2 > t0.c0))"; + @bind = (1234, 1); + + +Observe that the condition on C in the subquery refers to +column C of the main query : this is I a bind +value, so we have to express it through a scalar ref. +Writing C<< c2 => {">" => "t0.c0"} >> would have generated +C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly +what we wanted here. + +Another use of the subquery technique is when some SQL clauses need +parentheses, as it often occurs with some proprietary SQL extensions +like for example fulltext expressions, geospatial expressions, +NATIVE clauses, etc. Here is an example of a fulltext query in MySQL : + + my %where = ( + -nest => \["MATCH (col1, col2) AGAINST (?)" => qw/apples/] + ); + +Finally, here is an example where a subquery is used +for expressing unary negation: + + my ($sub_stmt, @sub_bind) + = $sql->where({age => [{"<" => 10}, {">" => 20}]}); + $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause + my %where = ( + lname => {like => '%son%'}, + -nest => \["NOT ($sub_stmt)" => @sub_bind], + ); + +This yields + + $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )" + @bind = ('%son%', 10, 20) + + + +=head2 Conclusion + These pages could go on for a while, since the nesting of the data structures this module can handle are pretty much unlimited (the module implements the C expansion as a recursive function @@ -1286,6 +1871,9 @@ knew everything ahead of time, you wouldn't have to worry about dynamically-generating SQL and could just hardwire it into your script. + + + =head1 ORDER BY CLAUSES Some functions take an order by clause. This can either be a scalar (just a @@ -1306,6 +1894,18 @@ or an array of either of the two previous forms. Examples: [colA => {-asc => 'colB'}] | ORDER BY colA, colB ASC ========================================================== + + +=head1 SPECIAL OPERATORS + +[to be written] + + +=head1 TABLES AND JOINS + +[to be written] + + =head1 PERFORMANCE Thanks to some benchmarking by Mark Stosberg, it turns out that @@ -1331,6 +1931,7 @@ the same structure, you only have to generate the SQL the first time around. On subsequent queries, simply use the C function provided by this module to return your values in the correct order. + =head1 FORMBUILDER If you use my C module at all, you'll hopefully @@ -1360,26 +1961,73 @@ a fast interface to returning and formatting data. I frequently use these three modules together to write complex database query apps in under 50 lines. -=head1 NOTES -There is not (yet) any explicit support for SQL compound logic -statements like "AND NOT". Instead, just do the de Morgan's -law transformations yourself. For example, this: +=head1 CHANGES + +Version 1.50 was a major internal refactoring of C. +Great care has been taken to preserve the I behavior +documented in previous versions in the 1.* family; however, +some features that were previously undocumented, or behaved +differently from the documentation, had to be changed in order +to clarify the semantics. Hence, client code that was relying +on some dark areas of C v1.* +B in v1.50. - "lname LIKE '%son%' AND NOT ( age < 10 OR age > 20 )" +=head1 Public changes -Becomes: +=over - "lname LIKE '%son%' AND ( age >= 10 AND age <= 20 )" +=item * -With the corresponding C<%where> hash: +support for literal SQL through the C<< \ [$sql, bind] >> syntax. + +=item * + +added -nest1, -nest2 or -nest_1, -nest_2, ... + +=item * + +optional support for L + +=item * + +defensive programming : check arguments + +=item * + +fixed bug with global logic, which was previously implemented +through global variables yielding side-effects. Prior versons would +interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >> +as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>. +Now this is interpreted +as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>. + +=item * + +C<-and> / C<-or> operators are no longer accepted +in the middle of an arrayref : they are +only admitted if in first position. + +=item * + +changed logic for distributing an op over arrayrefs + +=item * + +fixed semantics of _bindtype on array args + +=item * + +dropped the C<_anoncopy> of the %where tree. No longer necessary, +we just avoid shifting arrays within that tree. + +=item * + +dropped the C<_modlogic> function + +=back - %where = ( - lname => {like => '%son%'}, - age => [-and => {'>=', 10}, {'<=', 20}], - ); -Again, remember that the C<-and> goes I the arrayref. =head1 ACKNOWLEDGEMENTS @@ -1396,6 +2044,7 @@ so I have no idea who they are! But the people I do know are: Mike Fragassi (enhancements to "BETWEEN" and "LIKE") Dan Kubb (support for "quote_char" and "name_sep") Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by) + Laurent Dami (internal refactoring, multiple -nest, extensible list of special operators, literal SQL) Thanks! diff --git a/t/00new.t b/t/00new.t old mode 100755 new mode 100644 index b90dc8a..989a0b2 --- a/t/00new.t +++ b/t/00new.t @@ -4,16 +4,28 @@ use strict; use warnings; use Test::More; +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; + plan tests => 15; use_ok('SQL::Abstract'); +#LDNOTE: renamed all "bind" into "where" because that's what they are + + my @handle_tests = ( #1 { args => {logic => 'OR'}, - stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )' +# stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )' +# LDNOTE: modified the line above (changing the test suite!!!) because +# the test was not consistent with the doc: hashrefs should not be +# influenced by the current logic, they always mean 'AND'. So +# { a => 4, b => 0} should ALWAYS mean ( a = ? AND b = ? ). + stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #2 { @@ -33,7 +45,9 @@ my @handle_tests = ( #5 { args => {cmp => "=", logic => 'or'}, - stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )' +# LDNOTE idem +# stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? )' + stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #6 { @@ -43,7 +57,9 @@ my @handle_tests = ( #7 { args => {logic => "or", cmp => "like"}, - stmt => 'SELECT * FROM test WHERE ( a LIKE ? OR b LIKE ? )' +# LDNOTE idem +# stmt => 'SELECT * FROM test WHERE ( a LIKE ? OR b LIKE ? )' + stmt => 'SELECT * FROM test WHERE ( a LIKE ? AND b LIKE ? )' }, #8 { @@ -74,25 +90,40 @@ my @handle_tests = ( { args => {convert => "lower"}, stmt => 'SELECT * FROM test WHERE ( ( LOWER(ticket) = LOWER(?) ) OR ( LOWER(hostname) = LOWER(?) ) OR ( LOWER(taco) = LOWER(?) ) OR ( LOWER(salami) = LOWER(?) ) )', - bind => [ { ticket => 11 }, { hostname => 11 }, { taco => 'salad' }, { salami => 'punch' } ], + where => [ { ticket => 11 }, { hostname => 11 }, { taco => 'salad' }, { salami => 'punch' } ], }, #14 { args => {convert => "upper"}, - stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) OR ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )', - bind => [ { ticket => [11, 12, 13], hostname => { in => ['ntf', 'avd', 'bvd', '123'] } }, +# LDNOTE : modified the test below, because modified the semantics +# of "e => { '!=', [qw(f g)] }" : generating "e != 'f' OR e != 'g'" +# is nonsense (will always be true whatever the value of e). Since +# this is a 'negative' operator, we must apply the Morgan laws and +# interpret it as "e != 'f' AND e != 'g'" (and actually the user +# should rather write "e => {-not_in => [qw/f g/]}". + +# stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) OR ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )', + stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) AND ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )', + where => [ { ticket => [11, 12, 13], + hostname => { in => ['ntf', 'avd', 'bvd', '123'] } }, { tack => { between => [qw/tick tock/] } }, - { a => [qw/b c d/], e => { '!=', [qw(f g)] }, q => { 'not in', [14..20] } } ], + { a => [qw/b c d/], + e => { '!=', [qw(f g)] }, + q => { 'not in', [14..20] } } ], }, ); for (@handle_tests) { - local $" = ', '; - #print "creating a handle with args ($_->{args}): "; - my $sql = SQL::Abstract->new($_->{args}); - my $bind = $_->{bind} || { a => 4, b => 0}; - my($stmt, @bind) = $sql->select('test', '*', $bind); - ok($stmt eq $_->{stmt} && @bind); + local $" = ', '; + #print "creating a handle with args ($_->{args}): "; + my $sql = SQL::Abstract->new($_->{args}); + my $where = $_->{where} || { a => 4, b => 0}; + my($stmt, @bind) = $sql->select('test', '*', $where); + + # LDNOTE: this original test suite from NWIGER did no comparisons + # on @bind values, just checking if @bind is nonempty. + # So here we just fake a [1] bind value for the comparison. + is_same_sql_bind($stmt, [@bind ? 1 : 0], $_->{stmt}, [1]); } diff --git a/t/01generate.t b/t/01generate.t old mode 100755 new mode 100644 index 33d9062..9fbae62 --- a/t/01generate.t +++ b/t/01generate.t @@ -4,8 +4,11 @@ use strict; use warnings; use Test::More; +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; -plan tests => 60; +plan tests => 64; use SQL::Abstract; @@ -176,7 +179,7 @@ my @tests = ( #21 { func => 'update', - args => ['test', {a => 1, b => ["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}], + args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )', bind => [qw(1 02/02/02 1 2)], @@ -245,10 +248,13 @@ my @tests = ( tasty => { '!=', [qw(yes YES)] }, -nest => [ face => [ -or => {'=', 'mr.happy'}, {'=', undef} ] ] }, ], +# LDNOTE : modified the test below, same reasons as #14 in 00where.t stmt => 'UPDATE taco_punches SET one = ?, three = ? WHERE ( ( ( ( ( face = ? ) OR ( face IS NULL ) ) ) )' - . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) OR ( tasty != ? ) ) )', +# . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) OR ( tasty != ? ) ) )', + . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) AND ( tasty != ? ) ) )', stmt_q => 'UPDATE `taco_punches` SET `one` = ?, `three` = ? WHERE ( ( ( ( ( `face` = ? ) OR ( `face` IS NULL ) ) ) )' - . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) OR ( `tasty` != ? ) ) )', +# . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) OR ( `tasty` != ? ) ) )', + . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) AND ( `tasty` != ? ) ) )', bind => [qw(2 4 mr.happy yes YES yes YES)], }, #29 @@ -256,18 +262,29 @@ my @tests = ( func => 'select', args => ['jeff', '*', { name => {'like', '%smith%', -not_in => ['Nate','Jim','Bob','Sally']}, -nest => [ -or => [ -and => [age => { -between => [20,30] }, age => {'!=', 25} ], - yob => {'<', 1976} ] ] } ], - stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) )' - . ' AND name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? )', - stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( ( ( `age` BETWEEN ? AND ? ) AND ( `age` != ? ) ) ) OR ( `yob` < ? ) ) ) )' - . ' AND `name` NOT IN ( ?, ?, ?, ? ) AND `name` LIKE ? )', + yob => {'<', 1976} ] ] } ], +# LDNOTE : original test below was WRONG with respect to the doc. +# [-and, [cond1, cond2], cond3] should mean (cond1 OR cond2) AND cond3 +# instead of (cond1 AND cond2) OR cond3. +# Probably a misconception because of '=>' notation +# in [-and => [cond1, cond2], cond3]. +# Also some differences in parentheses, but without impact on semantics. +# stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) )' +# . ' AND name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? )', +# stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( ( ( `age` BETWEEN ? AND ? ) AND ( `age` != ? ) ) ) OR ( `yob` < ? ) ) ) )' +# . ' AND `name` NOT IN ( ?, ?, ?, ? ) AND `name` LIKE ? )', + stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( age BETWEEN ? AND ? ) OR ( age != ? ) ) AND ( yob < ? ) ) )' + . ' AND ( name NOT IN ( ?, ?, ?, ? ) AND name LIKE ? ) )', + stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( `age` BETWEEN ? AND ? ) OR ( `age` != ? ) ) AND ( `yob` < ? ) ) )' + . ' AND ( `name` NOT IN ( ?, ?, ?, ? ) AND `name` LIKE ? ) )', bind => [qw(20 30 25 1976 Nate Jim Bob Sally %smith%)] }, #30 { - # The "-maybe" should be ignored, as it sits at the top level (bug?) func => 'update', - args => ['fhole', {fpoles => 4}, [-maybe => {race => [-and => [qw(black white asian)]]}, +# LDNOTE : removed the "-maybe", because we no longer admit unknown ops +# args => ['fhole', {fpoles => 4}, [-maybe => {race => [-and => [qw(black white asian)]]}, + args => ['fhole', {fpoles => 4}, [ {race => [-and => [qw(black white asian)]]}, {-nest => {firsttime => [-or => {'=','yes'}, undef]}}, [ -and => {firstname => {-not_like => 'candace'}}, {lastname => {-in => [qw(jugs canyon towers)]}} ] ] ], stmt => 'UPDATE fhole SET fpoles = ? WHERE ( ( ( ( ( ( ( race = ? ) OR ( race = ? ) OR ( race = ? ) ) ) ) ) )' @@ -276,51 +293,48 @@ my @tests = ( . ' OR ( ( ( ( `firsttime` = ? ) OR ( `firsttime` IS NULL ) ) ) ) OR ( ( ( `firstname` NOT LIKE ? ) ) AND ( `lastname` IN ( ?, ?, ? ) ) ) )', bind => [qw(4 black white asian yes candace jugs canyon towers)] }, + #31 + { + func => 'insert', + args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}], + stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', + stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', + bind => [qw(1 02/02/02)], + }, + #32 + { + func => 'select', +# LDNOTE: modified test below because we agreed with MST that literal SQL +# should not automatically insert a '='; the user has to do it +# args => ['test', '*', { a => \["to_date(?, 'MM/DD/YY')", '02/02/02']}], + args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}], + stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, + stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, + bind => ['02/02/02'], + } ); use Data::Dumper; for (@tests) { - local $"=', '; + local $"=', '; - my $new = $_->{new} || {}; - $new->{debug} = $ENV{DEBUG} || 0; - my $sql = SQL::Abstract->new(%$new); + my $new = $_->{new} || {}; + $new->{debug} = $ENV{DEBUG} || 0; + my $sql = SQL::Abstract->new(%$new); - #print "testing with args (@{$_->{args}}): "; - my $func = $_->{func}; - my($stmt, @bind) = $sql->$func(@{$_->{args}}); - ok($stmt eq $_->{stmt} && equal(\@bind, $_->{bind})) or - print "got\n", - "[$stmt] [",Dumper(\@bind),"]\n", - "instead of\n", - "[$_->{stmt}] [",Dumper($_->{bind}),"]\n\n"; + #print "testing with args (@{$_->{args}}): "; + my $func = $_->{func}; + my($stmt, @bind) = $sql->$func(@{$_->{args}}); + is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); - # test with quoted labels - my $sql_q = SQL::Abstract->new(%$new, quote_char => '`', name_sep => '.'); + # test with quoted labels + my $sql_q = SQL::Abstract->new(%$new, quote_char => '`', name_sep => '.'); - my $func_q = $_->{func}; - my($stmt_q, @bind_q) = $sql_q->$func_q(@{$_->{args}}); - ok($stmt_q eq $_->{stmt_q} && equal(\@bind_q, $_->{bind})) or - print "got\n", - "[$stmt_q] [",Dumper(\@bind_q),"]\n", - "instead of\n", - "[$_->{stmt_q}] [",Dumper($_->{bind}),"]\n\n"; -} + my $func_q = $_->{func}; + my($stmt_q, @bind_q) = $sql_q->$func_q(@{$_->{args}}); -sub equal { - my ($a, $b) = @_; - return 0 if @$a != @$b; - for (my $i = 0; $i < $#{$a}; $i++) { - next if (! defined($a->[$i])) && (! defined($b->[$i])); - if (ref $a->[$i] && ref $b->[$i]) { - return 0 if $a->[$i][0] ne $b->[$i][0] - || $a->[$i][1] ne $b->[$i][1]; - } else { - return 0 if $a->[$i] ne $b->[$i]; - } - } - return 1; + is_same_sql_bind($stmt_q, \@bind_q, $_->{stmt_q}, $_->{bind}); } diff --git a/t/02where.t b/t/02where.t old mode 100755 new mode 100644 index 7c36091..b279651 --- a/t/02where.t +++ b/t/02where.t @@ -5,7 +5,11 @@ use warnings; use Test::More; use Test::Exception; -plan tests => 27; +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; + +plan tests => 15; use SQL::Abstract; @@ -71,7 +75,9 @@ my @handle_tests = ( completion_date => { 'between', ['2002-10-01', '2003-02-06'] }, }, order => \'ticket, requestor', - stmt => " WHERE ( completion_date BETWEEN ? AND ? AND status = ? ) ORDER BY ticket, requestor", +#LDNOTE: modified parentheses +# stmt => " WHERE ( completion_date BETWEEN ? AND ? AND status = ? ) ORDER BY ticket, requestor", + stmt => " WHERE ( ( completion_date BETWEEN ? AND ? ) AND status = ? ) ORDER BY ticket, requestor", bind => [qw/2002-10-01 2003-02-06 completed/], }, @@ -118,7 +124,9 @@ my @handle_tests = ( requestor => { 'like', undef }, }, order => \'requestor, ticket', - stmt => " WHERE ( priority BETWEEN ? AND ? AND requestor IS NULL ) ORDER BY requestor, ticket", +#LDNOTE: modified parentheses +# stmt => " WHERE ( priority BETWEEN ? AND ? AND requestor IS NULL ) ORDER BY requestor, ticket", + stmt => " WHERE ( ( priority BETWEEN ? AND ? ) AND requestor IS NULL ) ORDER BY requestor, ticket", bind => [qw/1 3/], }, @@ -131,7 +139,9 @@ my @handle_tests = ( '>' => 10, }, }, - stmt => " WHERE ( id = ? AND num <= ? AND num > ? )", +# LDNOTE : modified test below, just parentheses differ +# stmt => " WHERE ( id = ? AND num <= ? AND num > ? )", + stmt => " WHERE ( id = ? AND ( num <= ? AND num > ? ) )", bind => [qw/1 20 10/], }, @@ -143,7 +153,10 @@ my @handle_tests = ( wix => {'in' => [qw/zz yy/]}, wux => {'not_in' => [qw/30 40/]} }, - stmt => " WHERE ( ( ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND nix BETWEEN ? AND ? AND nox NOT BETWEEN ? AND ? AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )", +# LDNOTE: modified parentheses for BETWEEN (trivial). +# Also modified the logic of "not_like" (severe, same reasons as #14 in 00where.t) +# stmt => " WHERE ( ( ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND nix BETWEEN ? AND ? AND nox NOT BETWEEN ? AND ? AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )", + stmt => " WHERE ( ( foo NOT LIKE ? AND foo NOT LIKE ? AND foo NOT LIKE ? ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND ( nix BETWEEN ? AND ? ) AND ( nox NOT BETWEEN ? AND ? ) AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )", bind => [7,8,9,'a','b',100,200,150,160,'zz','yy','30','40'], }, @@ -156,13 +169,22 @@ my @handle_tests = ( bind => [], }, + + { + where => { + foo => \["IN (?, ?)", 22, 33], + bar => [-and => \["> ?", 44], \["< ?", 55] ], + }, + stmt => " WHERE ( (bar > ? AND bar < ?) AND foo IN (?, ?) )", + bind => [44, 55, 22, 33], + }, + ); for my $case (@handle_tests) { my $sql = SQL::Abstract->new; my($stmt, @bind) = $sql->where($case->{where}, $case->{order}); - is($stmt, $case->{stmt}); - is_deeply(\@bind, $case->{bind}); + is_same_sql_bind($stmt, \@bind, $case->{stmt}, $case->{bind}) } dies_ok { diff --git a/t/03values.t b/t/03values.t old mode 100755 new mode 100644 index 3730b7f..f5e4ffc --- a/t/03values.t +++ b/t/03values.t @@ -4,6 +4,9 @@ use strict; use warnings; use Test::More; +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; plan tests => 5; diff --git a/t/04from.t b/t/04from.t deleted file mode 100644 index 2803389..0000000 --- a/t/04from.t +++ /dev/null @@ -1,67 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; -use Test::More; - - -plan tests => 4; - -use SQL::Abstract; - -my $sa = new SQL::Abstract; - -my @j = ( - { child => 'person' }, - [ { father => 'person' }, { 'father.person_id' => 'child.father_id' }, ], - [ { mother => 'person' }, { 'mother.person_id' => 'child.mother_id' } ], -); -my $match = 'person child JOIN person father ON ( father.person_id = ' - . 'child.father_id ) JOIN person mother ON ( mother.person_id ' - . '= child.mother_id )' - ; -is( $sa->_recurse_from(@j), $match, 'join 1 ok' ); - -my @j2 = ( - { mother => 'person' }, - [ [ { child => 'person' }, - [ { father => 'person' }, - { 'father.person_id' => 'child.father_id' } - ] - ], - { 'mother.person_id' => 'child.mother_id' } - ], -); -$match = 'person mother JOIN (person child JOIN person father ON (' - . ' father.person_id = child.father_id )) ON ( mother.person_id = ' - . 'child.mother_id )' - ; -is( $sa->_recurse_from(@j2), $match, 'join 2 ok' ); - -my @j3 = ( - { child => 'person' }, - [ { father => 'person', -join_type => 'inner' }, { 'father.person_id' => 'child.father_id' }, ], - [ { mother => 'person', -join_type => 'inner' }, { 'mother.person_id' => 'child.mother_id' } ], -); -$match = 'person child INNER JOIN person father ON ( father.person_id = ' - . 'child.father_id ) INNER JOIN person mother ON ( mother.person_id ' - . '= child.mother_id )' - ; - -is( $sa->_recurse_from(@j3), $match, 'join 3 (inner join) ok'); - -my @j4 = ( - { mother => 'person' }, - [ [ { child => 'person', -join_type => 'left' }, - [ { father => 'person', -join_type => 'right' }, - { 'father.person_id' => 'child.father_id' } - ] - ], - { 'mother.person_id' => 'child.mother_id' } - ], -); -$match = 'person mother LEFT JOIN (person child RIGHT JOIN person father ON (' - . ' father.person_id = child.father_id )) ON ( mother.person_id = ' - . 'child.mother_id )' - ; -is( $sa->_recurse_from(@j4), $match, 'join 4 (nested joins + join types) ok'); diff --git a/t/05quotes.t b/t/05quotes.t deleted file mode 100644 index 361038f..0000000 --- a/t/05quotes.t +++ /dev/null @@ -1,188 +0,0 @@ -use strict; -use warnings; - -use vars qw($TESTING); -$TESTING = 1; -use Test::More; - -# use a BEGIN block so we print our plan before SQL::Abstract is loaded -BEGIN { plan tests => 7 } - -use SQL::Abstract; - -my $sql_maker = SQL::Abstract->new; - -$sql_maker->{quote_char} = '`'; -$sql_maker->{name_sep} = '.'; - -my ($sql,) = $sql_maker->select( - [ - { - 'me' => 'cd' - }, - [ - { - 'artist' => 'artist', - '-join_type' => '' - }, - { - 'artist.artistid' => 'me.artist' - } - ] - ], - [ - #{ - # 'count' => '*' - #} - \'COUNT( * )' - ], - { - 'artist.name' => 'Caterwauler McCrae', - 'me.year' => 2001 - }, - [], - undef, - undef -); - -is($sql, - q/SELECT COUNT( * ) FROM `cd` `me` JOIN `artist` `artist` ON ( `artist`.`artistid` = `me`.`artist` ) WHERE ( `artist`.`name` = ? AND `me`.`year` = ? )/, - 'got correct SQL for count query with quoting'); - - -($sql,) = $sql_maker->select( - [ - { - 'me' => 'cd' - } - ], - [ - 'me.cdid', - 'me.artist', - 'me.title', - 'me.year' - ], - undef, - [ - { -desc => 'year' } - ], - undef, - undef -); - - - - -is($sql, - q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY `year` DESC/, - 'quoted ORDER BY with DESC okay'); - - -($sql,) = $sql_maker->select( - [ - { - 'me' => 'cd' - } - ], - [ - 'me.*' - ], - undef, - [], - undef, - undef -); - -is($sql, q/SELECT `me`.* FROM `cd` `me`/, 'select attr with me.* is right'); - -($sql,) = $sql_maker->select( - [ - { - 'me' => 'cd' - } - ], - [ - 'me.cdid', - 'me.artist', - 'me.title', - 'me.year' - ], - undef, - [ - \'year DESC' - ], - undef, - undef -); - -is($sql, - q/SELECT `me`.`cdid`, `me`.`artist`, `me`.`title`, `me`.`year` FROM `cd` `me` ORDER BY year DESC/, - 'did not quote ORDER BY with scalarref'); - -my %data = ( - name => 'Bill', - order => 12 -); - -my @binds; - -($sql,@binds) = $sql_maker->update( - 'group', - { - 'order' => '12', - 'name' => 'Bill' - } -); - -is($sql, - q/UPDATE `group` SET `name` = ?, `order` = ?/, - 'quoted table names for UPDATE'); - -$sql_maker->{quote_char} = [qw/[ ]/]; - -($sql,) = $sql_maker->select( - [ - { - 'me' => 'cd' - }, - [ - { - 'artist' => 'artist', - '-join_type' => '' - }, - { - 'artist.artistid' => 'me.artist' - } - ] - ], - [ - #{ - # 'count' => '*' - #} - \'COUNT( * )' - ], - { - 'artist.name' => 'Caterwauler McCrae', - 'me.year' => 2001 - }, - [], - undef, - undef -); - -is($sql, - q/SELECT COUNT( * ) FROM [cd] [me] JOIN [artist] [artist] ON ( [artist].[artistid] = [me].[artist] ) WHERE ( [artist].[name] = ? AND [me].[year] = ? )/, - 'got correct SQL for count query with bracket quoting'); - - -($sql,@binds) = $sql_maker->update( - 'group', - { - 'order' => '12', - 'name' => 'Bill' - } -); - -is($sql, - q/UPDATE [group] SET [name] = ?, [order] = ?/, - 'bracket quoted table names for UPDATE'); diff --git a/t/06order_by.t b/t/06order_by.t index 20ca3f4..a8fc1c7 100644 --- a/t/06order_by.t +++ b/t/06order_by.t @@ -6,6 +6,10 @@ use Test::More; use SQL::Abstract; +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; + my @cases = ( { diff --git a/t/07subqueries.t b/t/07subqueries.t new file mode 100644 index 0000000..b3840d5 --- /dev/null +++ b/t/07subqueries.t @@ -0,0 +1,95 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More; + +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; + +plan tests => 5; + +use SQL::Abstract; + +my $sql = SQL::Abstract->new; + +my (@tests, $sub_stmt, @sub_bind, $where); + +#1 +($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", + 100, "foo%"); +$where = { + foo => 1234, + bar => \["IN ($sub_stmt)" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )", + bind => [100, "foo%", 1234], +}; + +#2 +($sub_stmt, @sub_bind) + = $sql->select("t1", "c1", {c2 => {"<" => 100}, + c3 => {-like => "foo%"}}); +$where = { + foo => 1234, + bar => \["> ALL ($sub_stmt)" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )", + bind => [100, "foo%", 1234], +}; + +#3 +($sub_stmt, @sub_bind) + = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); +$where = { + foo => 1234, + -nest => \["EXISTS ($sub_stmt)" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )", + bind => [1, 1234], +}; + +#4 +$where = { + -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"], + }; +push @tests, { + where => $where, + stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )", + bind => ["apples"], +}; + + +#5 +($sub_stmt, @sub_bind) + = $sql->where({age => [{"<" => 10}, {">" => 20}]}); +$sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause +$where = { + lname => {-like => '%son%'}, + -nest => \["NOT ( $sub_stmt )" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )", + bind => [10, 20, '%son%'], +}; + + + +for (@tests) { + + my($stmt, @bind) = $sql->where($_->{where}, $_->{order}); + is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); +} + + + + + diff --git a/t/08special_ops.t b/t/08special_ops.t new file mode 100644 index 0000000..5bc5996 --- /dev/null +++ b/t/08special_ops.t @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More; + +use FindBin; +use lib "$FindBin::Bin"; +use TestSqlAbstract; + +plan tests => 2; + +use SQL::Abstract; + +my $sqlmaker = SQL::Abstract->new(special_ops => [ + + # special op for MySql MATCH (field) AGAINST(word1, word2, ...) + {regex => qr/^match$/i, + handler => sub { + my ($self, $field, $op, $arg) = @_; + $arg = [$arg] if not ref $arg; + my $label = $self->_quote($field); + my ($placeholder) = $self->_convert('?'); + my $placeholders = join ", ", (($placeholder) x @$arg); + my $sql = $self->_sqlcase('match') . " ($label) " + . $self->_sqlcase('against') . " ($placeholders) "; + my @bind = $self->_bindtype($field, @$arg); + return ($sql, @bind); + } + }, + + # special op for Basis+ NATIVE + {regex => qr/^native$/i, + handler => sub { + my ($self, $field, $op, $arg) = @_; + $arg =~ s/'/''/g; + my $sql = "NATIVE (' $field $arg ')"; + return ($sql); + } + }, + +]); + +my @tests = ( + + #1 + { where => {foo => {-match => 'foo'}, + bar => {-match => [qw/foo bar/]}}, + stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )", + bind => [qw/foo bar foo/], + }, + + #2 + { where => {foo => {-native => "PH IS 'bar'"}}, + stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )", + bind => [], + }, + +); + + +for (@tests) { + + my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order}); + is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); +} + + + + + diff --git a/t/TestSqlAbstract.pm b/t/TestSqlAbstract.pm new file mode 100644 index 0000000..ba8a100 --- /dev/null +++ b/t/TestSqlAbstract.pm @@ -0,0 +1,137 @@ +package TestSqlAbstract; + +# compares two SQL expressions on their abstract syntax, +# ignoring differences in levels of parentheses. + +use strict; +use warnings; +use Test::More; +use base 'Exporter'; +use Data::Dumper; + +our @EXPORT = qw/is_same_sql_bind/; + + +my $last_differ; + +sub is_same_sql_bind { + my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; + + my $tree1 = parse($sql1); + my $tree2 = parse($sql2); + my $same_sql = eq_tree($tree1, $tree2); + my $same_bind = stringify_bind($bind_ref1) eq stringify_bind($bind_ref2); + ok($same_sql && $same_bind, $msg); + if (!$same_sql) { + diag "SQL expressions differ\n" + ." got: $sql1\n" + ."expected: $sql2\n" + ."differing in :\n$last_differ\n"; + ; + } + if (!$same_bind) { + diag "BIND values differ\n" + ." got: " . Dumper($bind_ref1) + ."expected: " . Dumper($bind_ref2) + ; + } +} + +sub stringify_bind { + my $bind_ref = shift || []; + return join "///", map {ref $_ ? join('=>', @$_) : ($_ || '')} + @$bind_ref; +} + + + +sub eq_tree { + my ($left, $right) = @_; + + # ignore top-level parentheses + while ($left->[0] eq 'PAREN') {$left = $left->[1] } + while ($right->[0] eq 'PAREN') {$right = $right->[1]} + + if ($left->[0] ne $right->[0]) { # if operators are different + $last_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", + unparse($left), + unparse($right); + return 0; + } + else { # else compare operands + if ($left->[0] eq 'EXPR' ) { + if ($left->[1] ne $right->[1]) { + $last_differ = "[$left->[1]] != [$right->[1]]\n"; + return 0; + } + else { + return 1; + } + } + else { + my $eq_left = eq_tree($left->[1][0], $right->[1][0]); + my $eq_right = eq_tree($left->[1][1], $right->[1][1]); + return $eq_left && $eq_right; + } + } +} + + +my @tokens; + +sub parse { + my $s = shift; + + # tokenize string + @tokens = grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s; + + my $tree = _recurse_parse(); + return $tree; +} + +sub _recurse_parse { + + my $left; + while (1) { + + my $lookahead = $tokens[0]; + return $left if !defined($lookahead) || $lookahead eq ')'; + + my $token = shift @tokens; + + if ($token eq '(') { + my $right = _recurse_parse(); + $token = shift @tokens + or die "missing ')'"; + $token eq ')' + or die "unexpected token : $token"; + $left = $left ? [CONCAT => [$left, [PAREN => $right]]] + : [PAREN => $right]; + } + elsif ($token eq 'AND' || $token eq 'OR') { + my $right = _recurse_parse(); + $left = [$token => [$left, $right]]; + } + else { + $left = $left ? [CONCAT => [$left, [EXPR => $token]]] + : [EXPR => $token]; + } + } +} + + + +sub unparse { + my $tree = shift; + my $dispatch = { + EXPR => sub {$tree->[1] }, + PAREN => sub {"(" . unparse($tree->[1]) . ")" }, + CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}}, + AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}}, + OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}}, + }; + $dispatch->{$tree->[0]}->(); +} + + +1;