--- /dev/null
+# This Makefile is for the SQL::Abstract extension to perl.\r
+#\r
+# It was generated automatically by MakeMaker version\r
+# 6.44 (Revision: 54639) from the contents of\r
+# Makefile.PL. Don't edit this file, edit Makefile.PL instead.\r
+#\r
+# ANY CHANGES MADE HERE WILL BE LOST!\r
+#\r
+# MakeMaker ARGV: ()\r
+#\r
+# MakeMaker Parameters:\r
+\r
+# ABSTRACT_FROM => q[lib/SQL/Abstract.pm]\r
+# AUTHOR => q[Nathan Wiger (nate@wiger.org)]\r
+# NAME => q[SQL::Abstract]\r
+# PREREQ_PM => { List::Util=>q[0] }\r
+# VERSION_FROM => q[lib/SQL/Abstract.pm]\r
+\r
+# --- MakeMaker post_initialize section:\r
+\r
+\r
+# --- MakeMaker const_config section:\r
+\r
+# These definitions are from config.sh (via d:/Perl/lib/Config.pm).\r
+# They may have been overridden via Makefile.PL or on the command line.\r
+AR = ar\r
+CC = gcc\r
+CCCDLFLAGS = \r
+CCDLFLAGS = \r
+DLEXT = dll\r
+DLSRC = dl_win32.xs\r
+EXE_EXT = .exe\r
+FULL_AR = \r
+LD = g++\r
+LDDLFLAGS = -mdll -L"d:\perl\lib\CORE"\r
+LDFLAGS = -L"d:\perl\lib\CORE"\r
+LIBC = msvcrt.lib\r
+LIB_EXT = .a\r
+OBJ_EXT = .o\r
+OSNAME = MSWin32\r
+OSVERS = 5.00\r
+RANLIB = rem\r
+SITELIBEXP = d:\Perl\site\lib\r
+SITEARCHEXP = d:\Perl\site\lib\r
+SO = dll\r
+VENDORARCHEXP = \r
+VENDORLIBEXP = \r
+\r
+\r
+# --- MakeMaker constants section:\r
+AR_STATIC_ARGS = cr\r
+DIRFILESEP = ^\\r
+DFSEP = $(DIRFILESEP)\r
+NAME = SQL::Abstract\r
+NAME_SYM = SQL_Abstract\r
+VERSION = 1.49_01\r
+VERSION_MACRO = VERSION\r
+VERSION_SYM = 1_49_01\r
+DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\"\r
+XS_VERSION = 1.49_01\r
+XS_VERSION_MACRO = XS_VERSION\r
+XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"\r
+INST_ARCHLIB = blib\arch\r
+INST_SCRIPT = blib\script\r
+INST_BIN = blib\bin\r
+INST_LIB = blib\lib\r
+INST_MAN1DIR = blib\man1\r
+INST_MAN3DIR = blib\man3\r
+MAN1EXT = 1\r
+MAN3EXT = 3\r
+INSTALLDIRS = site\r
+DESTDIR = \r
+PREFIX = $(SITEPREFIX)\r
+PERLPREFIX = d:\perl\r
+SITEPREFIX = d:\perl\site\r
+VENDORPREFIX = \r
+INSTALLPRIVLIB = d:\perl\lib\r
+DESTINSTALLPRIVLIB = $(DESTDIR)$(INSTALLPRIVLIB)\r
+INSTALLSITELIB = d:\perl\site\lib\r
+DESTINSTALLSITELIB = $(DESTDIR)$(INSTALLSITELIB)\r
+INSTALLVENDORLIB = \r
+DESTINSTALLVENDORLIB = $(DESTDIR)$(INSTALLVENDORLIB)\r
+INSTALLARCHLIB = d:\perl\lib\r
+DESTINSTALLARCHLIB = $(DESTDIR)$(INSTALLARCHLIB)\r
+INSTALLSITEARCH = d:\perl\site\lib\r
+DESTINSTALLSITEARCH = $(DESTDIR)$(INSTALLSITEARCH)\r
+INSTALLVENDORARCH = \r
+DESTINSTALLVENDORARCH = $(DESTDIR)$(INSTALLVENDORARCH)\r
+INSTALLBIN = d:\perl\bin\r
+DESTINSTALLBIN = $(DESTDIR)$(INSTALLBIN)\r
+INSTALLSITEBIN = d:\perl\site\bin\r
+DESTINSTALLSITEBIN = $(DESTDIR)$(INSTALLSITEBIN)\r
+INSTALLVENDORBIN = \r
+DESTINSTALLVENDORBIN = $(DESTDIR)$(INSTALLVENDORBIN)\r
+INSTALLSCRIPT = d:\perl\bin\r
+DESTINSTALLSCRIPT = $(DESTDIR)$(INSTALLSCRIPT)\r
+INSTALLSITESCRIPT = $(INSTALLSCRIPT)\r
+DESTINSTALLSITESCRIPT = $(DESTDIR)$(INSTALLSITESCRIPT)\r
+INSTALLVENDORSCRIPT = \r
+DESTINSTALLVENDORSCRIPT = $(DESTDIR)$(INSTALLVENDORSCRIPT)\r
+INSTALLMAN1DIR = d:\perl\man\man1\r
+DESTINSTALLMAN1DIR = $(DESTDIR)$(INSTALLMAN1DIR)\r
+INSTALLSITEMAN1DIR = $(INSTALLMAN1DIR)\r
+DESTINSTALLSITEMAN1DIR = $(DESTDIR)$(INSTALLSITEMAN1DIR)\r
+INSTALLVENDORMAN1DIR = \r
+DESTINSTALLVENDORMAN1DIR = $(DESTDIR)$(INSTALLVENDORMAN1DIR)\r
+INSTALLMAN3DIR = d:\perl\man\man3\r
+DESTINSTALLMAN3DIR = $(DESTDIR)$(INSTALLMAN3DIR)\r
+INSTALLSITEMAN3DIR = $(INSTALLMAN3DIR)\r
+DESTINSTALLSITEMAN3DIR = $(DESTDIR)$(INSTALLSITEMAN3DIR)\r
+INSTALLVENDORMAN3DIR = \r
+DESTINSTALLVENDORMAN3DIR = $(DESTDIR)$(INSTALLVENDORMAN3DIR)\r
+PERL_LIB = d:\Perl\lib\r
+PERL_ARCHLIB = d:\Perl\lib\r
+LIBPERL_A = libperl.a\r
+FIRST_MAKEFILE = Makefile\r
+MAKEFILE_OLD = Makefile.old\r
+MAKE_APERL_FILE = Makefile.aperl\r
+PERLMAINCC = $(CC)\r
+PERL_INC = D:\Perl\lib\CORE\r
+PERL = D:\Perl\bin\perl.exe\r
+FULLPERL = D:\Perl\bin\perl.exe\r
+ABSPERL = $(PERL)\r
+PERLRUN = $(PERL)\r
+FULLPERLRUN = $(FULLPERL)\r
+ABSPERLRUN = $(ABSPERL)\r
+PERLRUNINST = $(PERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"\r
+FULLPERLRUNINST = $(FULLPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"\r
+ABSPERLRUNINST = $(ABSPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"\r
+PERL_CORE = 0\r
+PERM_RW = 644\r
+PERM_RWX = 755\r
+\r
+MAKEMAKER = d:/Perl/lib/ExtUtils/MakeMaker.pm\r
+MM_VERSION = 6.44\r
+MM_REVISION = 54639\r
+\r
+# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).\r
+# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)\r
+# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)\r
+# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.\r
+MAKE = nmake\r
+FULLEXT = SQL\Abstract\r
+BASEEXT = Abstract\r
+PARENT_NAME = SQL\r
+DLBASE = $(BASEEXT)\r
+VERSION_FROM = lib/SQL/Abstract.pm\r
+OBJECT = \r
+LDFROM = $(OBJECT)\r
+LINKTYPE = dynamic\r
+BOOTDEP = \r
+\r
+# Handy lists of source code files:\r
+XS_FILES = \r
+C_FILES = \r
+O_FILES = \r
+H_FILES = \r
+MAN1PODS = \r
+MAN3PODS = lib/SQL/Abstract.pm\r
+\r
+# Where is the Config information that we are using/depend on\r
+CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h\r
+\r
+# Where to build things\r
+INST_LIBDIR = $(INST_LIB)\SQL\r
+INST_ARCHLIBDIR = $(INST_ARCHLIB)\SQL\r
+\r
+INST_AUTODIR = $(INST_LIB)\auto\$(FULLEXT)\r
+INST_ARCHAUTODIR = $(INST_ARCHLIB)\auto\$(FULLEXT)\r
+\r
+INST_STATIC = \r
+INST_DYNAMIC = \r
+INST_BOOT = \r
+\r
+# Extra linker info\r
+EXPORT_LIST = $(BASEEXT).def\r
+PERL_ARCHIVE = $(PERL_INC)\perl58.lib\r
+PERL_ARCHIVE_AFTER = \r
+\r
+\r
+TO_INST_PM = lib/SQL/Abstract.pm\r
+\r
+PM_TO_BLIB = lib/SQL/Abstract.pm \\r
+ blib\lib\SQL\Abstract.pm\r
+\r
+\r
+# --- MakeMaker platform_constants section:\r
+MM_Win32_VERSION = 6.44\r
+\r
+\r
+# --- MakeMaker tool_autosplit section:\r
+# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto\r
+AUTOSPLITFILE = $(ABSPERLRUN) -e "use AutoSplit; autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)" --\r
+\r
+\r
+\r
+# --- MakeMaker tool_xsubpp section:\r
+\r
+\r
+# --- MakeMaker tools_other section:\r
+CHMOD = $(ABSPERLRUN) -MExtUtils::Command -e chmod\r
+CP = $(ABSPERLRUN) -MExtUtils::Command -e cp\r
+MV = $(ABSPERLRUN) -MExtUtils::Command -e mv\r
+NOOP = rem\r
+NOECHO = @\r
+RM_F = $(ABSPERLRUN) -MExtUtils::Command -e rm_f\r
+RM_RF = $(ABSPERLRUN) -MExtUtils::Command -e rm_rf\r
+TEST_F = $(ABSPERLRUN) -MExtUtils::Command -e test_f\r
+TOUCH = $(ABSPERLRUN) -MExtUtils::Command -e touch\r
+UMASK_NULL = umask 0\r
+DEV_NULL = > NUL\r
+MKPATH = $(ABSPERLRUN) "-MExtUtils::Command" -e mkpath\r
+EQUALIZE_TIMESTAMP = $(ABSPERLRUN) "-MExtUtils::Command" -e eqtime\r
+ECHO = $(ABSPERLRUN) -l -e "print qq{@ARGV}" --\r
+ECHO_N = $(ABSPERLRUN) -e "print qq{@ARGV}" --\r
+UNINST = 0\r
+VERBINST = 0\r
+MOD_INSTALL = $(ABSPERLRUN) -MExtUtils::Install -e "install({@ARGV}, '$(VERBINST)', 0, '$(UNINST)');" --\r
+DOC_INSTALL = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e perllocal_install\r
+UNINSTALL = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e uninstall\r
+WARN_IF_OLD_PACKLIST = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e warn_if_old_packlist\r
+MACROSTART = \r
+MACROEND = \r
+USEMAKEFILE = -f\r
+FIXIN = pl2bat.bat\r
+\r
+\r
+# --- MakeMaker makemakerdflt section:\r
+makemakerdflt : all\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker dist section:\r
+TAR = tar\r
+TARFLAGS = cvf\r
+ZIP = zip\r
+ZIPFLAGS = -r\r
+COMPRESS = gzip --best\r
+SUFFIX = .gz\r
+SHAR = shar\r
+PREOP = $(NOECHO) $(NOOP)\r
+POSTOP = $(NOECHO) $(NOOP)\r
+TO_UNIX = $(NOECHO) $(NOOP)\r
+CI = ci -u\r
+RCS_LABEL = rcs -Nv$(VERSION_SYM): -q\r
+DIST_CP = best\r
+DIST_DEFAULT = tardist\r
+DISTNAME = SQL-Abstract\r
+DISTVNAME = SQL-Abstract-1.49_01\r
+\r
+\r
+# --- MakeMaker macro section:\r
+\r
+\r
+# --- MakeMaker depend section:\r
+\r
+\r
+# --- MakeMaker cflags section:\r
+\r
+\r
+# --- MakeMaker const_loadlibs section:\r
+\r
+\r
+# --- MakeMaker const_cccmd section:\r
+\r
+\r
+# --- MakeMaker post_constants section:\r
+\r
+\r
+# --- MakeMaker pasthru section:\r
+PASTHRU = -nologo\r
+\r
+# --- MakeMaker special_targets section:\r
+.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)\r
+\r
+.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir\r
+\r
+\r
+\r
+# --- MakeMaker c_o section:\r
+\r
+\r
+# --- MakeMaker xs_c section:\r
+\r
+\r
+# --- MakeMaker xs_o section:\r
+\r
+\r
+# --- MakeMaker top_targets section:\r
+all :: pure_all\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+pure_all :: config pm_to_blib subdirs linkext\r
+ $(NOECHO) $(NOOP)\r
+\r
+subdirs :: $(MYEXTLIB)\r
+ $(NOECHO) $(NOOP)\r
+\r
+config :: $(FIRST_MAKEFILE) blibdirs\r
+ $(NOECHO) $(NOOP)\r
+\r
+help :\r
+ perldoc ExtUtils::MakeMaker\r
+\r
+\r
+# --- MakeMaker blibdirs section:\r
+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\r
+ $(NOECHO) $(NOOP)\r
+\r
+# Backwards compat with 6.18 through 6.25\r
+blibdirs.ts : blibdirs\r
+ $(NOECHO) $(NOOP)\r
+\r
+$(INST_LIBDIR)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_LIBDIR)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_LIBDIR)\r
+ $(NOECHO) $(TOUCH) $(INST_LIBDIR)$(DFSEP).exists\r
+\r
+$(INST_ARCHLIB)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_ARCHLIB)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_ARCHLIB)\r
+ $(NOECHO) $(TOUCH) $(INST_ARCHLIB)$(DFSEP).exists\r
+\r
+$(INST_AUTODIR)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_AUTODIR)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_AUTODIR)\r
+ $(NOECHO) $(TOUCH) $(INST_AUTODIR)$(DFSEP).exists\r
+\r
+$(INST_ARCHAUTODIR)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_ARCHAUTODIR)\r
+ $(NOECHO) $(TOUCH) $(INST_ARCHAUTODIR)$(DFSEP).exists\r
+\r
+$(INST_BIN)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_BIN)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_BIN)\r
+ $(NOECHO) $(TOUCH) $(INST_BIN)$(DFSEP).exists\r
+\r
+$(INST_SCRIPT)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_SCRIPT)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_SCRIPT)\r
+ $(NOECHO) $(TOUCH) $(INST_SCRIPT)$(DFSEP).exists\r
+\r
+$(INST_MAN1DIR)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_MAN1DIR)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_MAN1DIR)\r
+ $(NOECHO) $(TOUCH) $(INST_MAN1DIR)$(DFSEP).exists\r
+\r
+$(INST_MAN3DIR)$(DFSEP).exists :: Makefile.PL\r
+ $(NOECHO) $(MKPATH) $(INST_MAN3DIR)\r
+ $(NOECHO) $(CHMOD) 755 $(INST_MAN3DIR)\r
+ $(NOECHO) $(TOUCH) $(INST_MAN3DIR)$(DFSEP).exists\r
+\r
+\r
+\r
+# --- MakeMaker linkext section:\r
+\r
+linkext :: $(LINKTYPE)\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker dlsyms section:\r
+\r
+Abstract.def: Makefile.PL\r
+ $(PERLRUN) -MExtUtils::Mksymlists \\r
+ -e "Mksymlists('NAME'=>\"SQL::Abstract\", 'DLBASE' => '$(BASEEXT)', 'DL_FUNCS' => { }, 'FUNCLIST' => [], 'IMPORTS' => { }, 'DL_VARS' => []);"\r
+\r
+\r
+# --- MakeMaker dynamic section:\r
+\r
+dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT)\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker dynamic_bs section:\r
+\r
+BOOTSTRAP =\r
+\r
+\r
+# --- MakeMaker dynamic_lib section:\r
+\r
+\r
+# --- MakeMaker static section:\r
+\r
+## $(INST_PM) has been moved to the all: target.\r
+## It remains here for awhile to allow for old usage: "make static"\r
+static :: $(FIRST_MAKEFILE) $(INST_STATIC)\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker static_lib section:\r
+\r
+\r
+# --- MakeMaker manifypods section:\r
+\r
+POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"\r
+POD2MAN = $(POD2MAN_EXE)\r
+\r
+\r
+manifypods : pure_all \\r
+ lib/SQL/Abstract.pm\r
+ $(NOECHO) $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) \\r
+ lib/SQL/Abstract.pm $(INST_MAN3DIR)\SQL.Abstract.$(MAN3EXT) \r
+\r
+\r
+\r
+\r
+# --- MakeMaker processPL section:\r
+\r
+\r
+# --- MakeMaker installbin section:\r
+\r
+\r
+# --- MakeMaker subdirs section:\r
+\r
+# none\r
+\r
+# --- MakeMaker clean_subdirs section:\r
+clean_subdirs :\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker clean section:\r
+\r
+# Delete temporary files but do not touch installed files. We don't delete\r
+# the Makefile here so a later make realclean still has a makefile to use.\r
+\r
+clean :: clean_subdirs\r
+ - $(RM_F) \\r
+ *$(LIB_EXT) core \\r
+ core.[0-9] core.[0-9][0-9] \\r
+ $(BASEEXT).bso $(INST_ARCHAUTODIR)\extralibs.ld \\r
+ pm_to_blib.ts core.[0-9][0-9][0-9][0-9] \\r
+ $(BASEEXT).x $(BOOTSTRAP) \\r
+ perl$(EXE_EXT) tmon.out \\r
+ $(INST_ARCHAUTODIR)\extralibs.all *$(OBJ_EXT) \\r
+ pm_to_blib blibdirs.ts \\r
+ core.[0-9][0-9][0-9][0-9][0-9] *perl.core \\r
+ core.*perl.*.? $(MAKE_APERL_FILE) \\r
+ perl $(BASEEXT).def \\r
+ core.[0-9][0-9][0-9] mon.out \\r
+ lib$(BASEEXT).def perlmain.c \\r
+ perl.exe so_locations \\r
+ $(BASEEXT).exp \r
+ - $(RM_RF) \\r
+ dll.exp dll.base \\r
+ blib \r
+ - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)\r
+\r
+\r
+# --- MakeMaker realclean_subdirs section:\r
+realclean_subdirs :\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker realclean section:\r
+# Delete temporary files (via clean) and also delete dist files\r
+realclean purge :: clean realclean_subdirs\r
+ - $(RM_F) \\r
+ $(MAKEFILE_OLD) $(FIRST_MAKEFILE) \r
+ - $(RM_RF) \\r
+ $(DISTVNAME) \r
+\r
+\r
+# --- MakeMaker metafile section:\r
+metafile : create_distdir\r
+ $(NOECHO) $(ECHO) Generating META.yml\r
+ $(NOECHO) $(ECHO) "--- #YAML:1.0" > META_new.yml\r
+ $(NOECHO) $(ECHO) "name: SQL-Abstract" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "version: 1.49_01" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "abstract: Generate SQL from Perl data structures" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "license: ~" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "author: " >> META_new.yml\r
+ $(NOECHO) $(ECHO) " - Nathan Wiger (nate@wiger.org)" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "generated_by: ExtUtils::MakeMaker version 6.44" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "distribution_type: module" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "requires: " >> META_new.yml\r
+ $(NOECHO) $(ECHO) " List::Util: 0" >> META_new.yml\r
+ $(NOECHO) $(ECHO) "meta-spec:" >> META_new.yml\r
+ $(NOECHO) $(ECHO) " url: http://module-build.sourceforge.net/META-spec-v1.3.html" >> META_new.yml\r
+ $(NOECHO) $(ECHO) " version: 1.3" >> META_new.yml\r
+ -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml\r
+\r
+\r
+# --- MakeMaker signature section:\r
+signature :\r
+ cpansign -s\r
+\r
+\r
+# --- MakeMaker dist_basics section:\r
+distclean :: realclean distcheck\r
+ $(NOECHO) $(NOOP)\r
+\r
+distcheck :\r
+ $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck\r
+\r
+skipcheck :\r
+ $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck\r
+\r
+manifest :\r
+ $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest\r
+\r
+veryclean : realclean\r
+ $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old \r
+\r
+\r
+\r
+# --- MakeMaker dist_core section:\r
+\r
+dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)\r
+ $(NOECHO) $(ABSPERLRUN) -l -e "print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'\\r
+ if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';" --\r
+\r
+tardist : $(DISTVNAME).tar$(SUFFIX)\r
+ $(NOECHO) $(NOOP)\r
+\r
+uutardist : $(DISTVNAME).tar$(SUFFIX)\r
+ uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu\r
+\r
+$(DISTVNAME).tar$(SUFFIX) : distdir\r
+ $(PREOP)\r
+ $(TO_UNIX)\r
+ $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)\r
+ $(RM_RF) $(DISTVNAME)\r
+ $(COMPRESS) $(DISTVNAME).tar\r
+ $(POSTOP)\r
+\r
+zipdist : $(DISTVNAME).zip\r
+ $(NOECHO) $(NOOP)\r
+\r
+$(DISTVNAME).zip : distdir\r
+ $(PREOP)\r
+ $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)\r
+ $(RM_RF) $(DISTVNAME)\r
+ $(POSTOP)\r
+\r
+shdist : distdir\r
+ $(PREOP)\r
+ $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar\r
+ $(RM_RF) $(DISTVNAME)\r
+ $(POSTOP)\r
+\r
+\r
+# --- MakeMaker distdir section:\r
+create_distdir :\r
+ $(RM_RF) $(DISTVNAME)\r
+ $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \\r
+ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"\r
+\r
+distdir : create_distdir distmeta \r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+\r
+# --- MakeMaker dist_test section:\r
+disttest : distdir\r
+ cd $(DISTVNAME)\r
+ $(ABSPERLRUN) Makefile.PL \r
+ $(MAKE) $(PASTHRU)\r
+ $(MAKE) test $(PASTHRU)\r
+ cd ..\r
+\r
+\r
+\r
+# --- MakeMaker dist_ci section:\r
+\r
+ci :\r
+ $(PERLRUN) "-MExtUtils::Manifest=maniread" \\r
+ -e "@all = keys %{ maniread() };" \\r
+ -e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \\r
+ -e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});"\r
+\r
+\r
+# --- MakeMaker distmeta section:\r
+distmeta : create_distdir metafile\r
+ $(NOECHO) cd $(DISTVNAME)\r
+ $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e "eval { maniadd({q{META.yml} => q{Module meta-data (added by MakeMaker)}}) } \\r
+ or print \"Could not add META.yml to MANIFEST: $${'@'}\n\"" --\r
+ cd ..\r
+\r
+\r
+\r
+# --- MakeMaker distsignature section:\r
+distsignature : create_distdir\r
+ $(NOECHO) cd $(DISTVNAME)\r
+ $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e "eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } \\r
+ or print \"Could not add SIGNATURE to MANIFEST: $${'@'}\n\"" --\r
+ cd ..\r
+ $(NOECHO) cd $(DISTVNAME)\r
+ $(TOUCH) SIGNATURE\r
+ cd ..\r
+ cd $(DISTVNAME)\r
+ cpansign -s\r
+ cd ..\r
+\r
+\r
+\r
+# --- MakeMaker install section:\r
+\r
+install :: all pure_install doc_install\r
+ $(NOECHO) $(NOOP)\r
+\r
+install_perl :: all pure_perl_install doc_perl_install\r
+ $(NOECHO) $(NOOP)\r
+\r
+install_site :: all pure_site_install doc_site_install\r
+ $(NOECHO) $(NOOP)\r
+\r
+install_vendor :: all pure_vendor_install doc_vendor_install\r
+ $(NOECHO) $(NOOP)\r
+\r
+pure_install :: pure_$(INSTALLDIRS)_install\r
+ $(NOECHO) $(NOOP)\r
+\r
+doc_install :: doc_$(INSTALLDIRS)_install\r
+ $(NOECHO) $(NOOP)\r
+\r
+pure__install : pure_site_install\r
+ $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site\r
+\r
+doc__install : doc_site_install\r
+ $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site\r
+\r
+pure_perl_install ::\r
+ $(NOECHO) $(MOD_INSTALL) \\r
+ read $(PERL_ARCHLIB)\auto\$(FULLEXT)\.packlist \\r
+ write $(DESTINSTALLARCHLIB)\auto\$(FULLEXT)\.packlist \\r
+ $(INST_LIB) $(DESTINSTALLPRIVLIB) \\r
+ $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \\r
+ $(INST_BIN) $(DESTINSTALLBIN) \\r
+ $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \\r
+ $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \\r
+ $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR)\r
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) \\r
+ $(SITEARCHEXP)\auto\$(FULLEXT)\r
+\r
+\r
+pure_site_install ::\r
+ $(NOECHO) $(MOD_INSTALL) \\r
+ read $(SITEARCHEXP)\auto\$(FULLEXT)\.packlist \\r
+ write $(DESTINSTALLSITEARCH)\auto\$(FULLEXT)\.packlist \\r
+ $(INST_LIB) $(DESTINSTALLSITELIB) \\r
+ $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \\r
+ $(INST_BIN) $(DESTINSTALLSITEBIN) \\r
+ $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \\r
+ $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \\r
+ $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR)\r
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) \\r
+ $(PERL_ARCHLIB)\auto\$(FULLEXT)\r
+\r
+pure_vendor_install ::\r
+ $(NOECHO) $(MOD_INSTALL) \\r
+ read $(VENDORARCHEXP)\auto\$(FULLEXT)\.packlist \\r
+ write $(DESTINSTALLVENDORARCH)\auto\$(FULLEXT)\.packlist \\r
+ $(INST_LIB) $(DESTINSTALLVENDORLIB) \\r
+ $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \\r
+ $(INST_BIN) $(DESTINSTALLVENDORBIN) \\r
+ $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \\r
+ $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \\r
+ $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR)\r
+\r
+doc_perl_install ::\r
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod\r
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)\r
+ -$(NOECHO) $(DOC_INSTALL) \\r
+ "Module" "$(NAME)" \\r
+ "installed into" "$(INSTALLPRIVLIB)" \\r
+ LINKTYPE "$(LINKTYPE)" \\r
+ VERSION "$(VERSION)" \\r
+ EXE_FILES "$(EXE_FILES)" \\r
+ >> $(DESTINSTALLARCHLIB)\perllocal.pod\r
+\r
+doc_site_install ::\r
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod\r
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)\r
+ -$(NOECHO) $(DOC_INSTALL) \\r
+ "Module" "$(NAME)" \\r
+ "installed into" "$(INSTALLSITELIB)" \\r
+ LINKTYPE "$(LINKTYPE)" \\r
+ VERSION "$(VERSION)" \\r
+ EXE_FILES "$(EXE_FILES)" \\r
+ >> $(DESTINSTALLARCHLIB)\perllocal.pod\r
+\r
+doc_vendor_install ::\r
+ $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod\r
+ -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)\r
+ -$(NOECHO) $(DOC_INSTALL) \\r
+ "Module" "$(NAME)" \\r
+ "installed into" "$(INSTALLVENDORLIB)" \\r
+ LINKTYPE "$(LINKTYPE)" \\r
+ VERSION "$(VERSION)" \\r
+ EXE_FILES "$(EXE_FILES)" \\r
+ >> $(DESTINSTALLARCHLIB)\perllocal.pod\r
+\r
+\r
+uninstall :: uninstall_from_$(INSTALLDIRS)dirs\r
+ $(NOECHO) $(NOOP)\r
+\r
+uninstall_from_perldirs ::\r
+ $(NOECHO) $(UNINSTALL) $(PERL_ARCHLIB)\auto\$(FULLEXT)\.packlist\r
+\r
+uninstall_from_sitedirs ::\r
+ $(NOECHO) $(UNINSTALL) $(SITEARCHEXP)\auto\$(FULLEXT)\.packlist\r
+\r
+uninstall_from_vendordirs ::\r
+ $(NOECHO) $(UNINSTALL) $(VENDORARCHEXP)\auto\$(FULLEXT)\.packlist\r
+\r
+\r
+# --- MakeMaker force section:\r
+# Phony target to force checking subdirectories.\r
+FORCE :\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+# --- MakeMaker perldepend section:\r
+\r
+\r
+# --- MakeMaker makefile section:\r
+# We take a very conservative approach here, but it's worth it.\r
+# We move Makefile to Makefile.old here to avoid gnu make looping.\r
+$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)\r
+ $(NOECHO) $(ECHO) "Makefile out-of-date with respect to $?"\r
+ $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."\r
+ -$(NOECHO) $(RM_F) $(MAKEFILE_OLD)\r
+ -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)\r
+ - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL)\r
+ $(PERLRUN) Makefile.PL \r
+ $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="\r
+ $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <=="\r
+ false\r
+\r
+\r
+\r
+# --- MakeMaker staticmake section:\r
+\r
+# --- MakeMaker makeaperl section ---\r
+MAP_TARGET = perl\r
+FULLPERL = D:\Perl\bin\perl.exe\r
+\r
+$(MAP_TARGET) :: static $(MAKE_APERL_FILE)\r
+ $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@\r
+\r
+$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib\r
+ $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)\r
+ $(NOECHO) $(PERLRUNINST) \\r
+ Makefile.PL DIR= \\r
+ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \\r
+ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=\r
+\r
+\r
+# --- MakeMaker test section:\r
+\r
+TEST_VERBOSE=0\r
+TEST_TYPE=test_$(LINKTYPE)\r
+TEST_FILE = test.pl\r
+TEST_FILES = t/*.t\r
+TESTDB_SW = -d\r
+\r
+testdb :: testdb_$(LINKTYPE)\r
+\r
+test :: $(TEST_TYPE) subdirs-test\r
+\r
+subdirs-test ::\r
+ $(NOECHO) $(NOOP)\r
+\r
+\r
+test_dynamic :: pure_all\r
+ $(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES)\r
+\r
+testdb_dynamic :: pure_all\r
+ $(FULLPERLRUN) $(TESTDB_SW) "-I$(INST_LIB)" "-I$(INST_ARCHLIB)" $(TEST_FILE)\r
+\r
+test_ : test_dynamic\r
+\r
+test_static :: test_dynamic\r
+testdb_static :: testdb_dynamic\r
+\r
+\r
+# --- MakeMaker ppd section:\r
+# Creates a PPD (Perl Package Description) for a binary distribution.\r
+ppd :\r
+ $(NOECHO) $(ECHO) "<SOFTPKG NAME=\"$(DISTNAME)\" VERSION=\"1,49_01,0,0\">" > $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <TITLE>$(DISTNAME)</TITLE>" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <ABSTRACT>Generate SQL from Perl data structures</ABSTRACT>" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <AUTHOR>Nathan Wiger (nate@wiger.org)</AUTHOR>" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <IMPLEMENTATION>" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <DEPENDENCY NAME=\"List-Util\" VERSION=\"0,0,0,0\" />" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <OS NAME=\"$(OSNAME)\" />" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\" />" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " <CODEBASE HREF=\"\" />" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) " </IMPLEMENTATION>" >> $(DISTNAME).ppd\r
+ $(NOECHO) $(ECHO) "</SOFTPKG>" >> $(DISTNAME).ppd\r
+\r
+\r
+# --- MakeMaker pm_to_blib section:\r
+\r
+pm_to_blib : $(TO_INST_PM)\r
+ $(NOECHO) $(ABSPERLRUN) -MExtUtils::Install -e "pm_to_blib({@ARGV}, '$(INST_LIB)\auto', '$(PM_FILTER)')" -- \\r
+ lib/SQL/Abstract.pm blib\lib\SQL\Abstract.pm \r
+ $(NOECHO) $(TOUCH) pm_to_blib\r
+\r
+\r
+# --- MakeMaker selfdocument section:\r
+\r
+\r
+# --- MakeMaker postamble section:\r
+\r
+\r
+# End.\r
-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
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<to_date> 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<SQL::Abstract> 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<to_date> 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
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<key=value> pairs are taken to mean
equality, and if you want to see if a field is within a set
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')
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
You can also override the comparsion on an individual basis - see
the huge section on L</"WHERE CLAUSES"> 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
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</"WHERE CLAUSES"> section for explanations.
+
=item convert
This will automatically convert comparisons using the specified SQL
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
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<SQL::Abstract>.
+See section L</"SPECIAL OPERATORS"> 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</"Inserting and Updating Arrays"> and
+L</"Inserting and Updating SQL"> 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<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
of bind values.
+See the sections on L</"Inserting and Updating Arrays"> and
+L</"Inserting and Updating SQL"> 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<WHERE clause|/WHERE CLAUSES>, and optional array or hash ref L<ORDER BY clause|/ORDER BY CLAUSES>, 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<WHERE clause|/"WHERE CLAUSES"> 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<ORDER BY clause|/"ORDER BY CLAUSES">
+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<WHERE clause|/WHERE CLAUSES>.
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,
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)
Using this allows you to markedly speed up your queries if you
are affecting lots of rows. See below under the L</"PERFORMANCE"> 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.
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<DBIx::Abstract>. It
is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
module is that things in arrays are OR'ed, and things in hashes
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 = (
$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:
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<AND> of its elements:
my %where = (
$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 => (
$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<AND>):
WHERE priority != ? AND priority != ?
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<OR>, but the modifier tells it
to use C<AND> instead. (Hint: You can use this in conjunction with the
-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<IN> comparison operator, by specifying the list as an arrayref:
$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<BETWEEN>, C<SOME>, and so forth. For example:
+The reverse operator C<-not_in> generates SQL C<NOT IN> 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',
WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
+These are the two builtin "special operators"; but the
+list can be expanded : see section L</"SPECIAL OPERATORS"> below.
+
+=head2 Nested conditions
+
So far, we've seen how multiple conditions are joined with a top-level
C<AND>. We can change this by putting the different conditions we want in
hashes and then putting those hashes in an array. For example:
( ( 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:
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<gt> 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<select()> :
+
+ 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<c2> in the subquery refers to
+column C<t0.c0> of the main query : this is I<not> 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<WHERE> expansion as a recursive function
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
[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
around. On subsequent queries, simply use the C<values> function provided
by this module to return your values in the correct order.
+
=head1 FORMBUILDER
If you use my C<CGI::FormBuilder> module at all, you'll hopefully
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<SQL::Abstract>.
+Great care has been taken to preserve the I<published> 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<SQL::Abstract> v1.*
+B<might behave differently> 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<array datatypes|/"Inserting and Updating Arrays">
+
+=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<inside> the arrayref.
=head1 ACKNOWLEDGEMENTS
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!
projects / dbsrgits/SQL-Abstract.git / commitdiff