* merged everything except for version bumps from fixes_3_0 till 37113

  * merged merges into release_3_0_4 after branching (37120:37149)

git-svn-id: branches/fixes_3_0_ios@37595 -

.gitattributes

@@ -1909,6 +1909,8 @@ packages/fcl-base/examples/cachetest.pp svneol=native#text/plain
 packages/fcl-base/examples/cfgtest.pp svneol=native#text/plain
 packages/fcl-base/examples/contit.pp svneol=native#text/plain
 packages/fcl-base/examples/crittest.pp svneol=native#text/plain
+packages/fcl-base/examples/csvbom.pp svneol=native#text/plain
+packages/fcl-base/examples/databom.txt svneol=native#text/plain
 packages/fcl-base/examples/dbugsrv.pp svneol=native#text/plain
 packages/fcl-base/examples/debugtest.pp svneol=native#text/plain
 packages/fcl-base/examples/decodeascii85.pp svneol=native#text/plain
@@ -2392,6 +2394,8 @@ packages/fcl-image/examples/Makefile.fpc svneol=native#text/plain
 packages/fcl-image/examples/drawing.pp svneol=native#text/plain
 packages/fcl-image/examples/imgconv.pp svneol=native#text/plain
 packages/fcl-image/examples/interpoldemo.pp svneol=native#text/plain
+packages/fcl-image/examples/pattern.png -text svneol=unset#image/png
+packages/fcl-image/examples/textout.pp svneol=native#text/plain
 packages/fcl-image/examples/xwdtobmp.pas svneol=native#text/plain
 packages/fcl-image/fpmake.pp svneol=native#text/plain
 packages/fcl-image/src/bmpcomn.pp svneol=native#text/plain
@@ -2453,15 +2457,19 @@ packages/fcl-js/Makefile svneol=native#text/plain
 packages/fcl-js/Makefile.fpc svneol=native#text/plain
 packages/fcl-js/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/fcl-js/README.TXT svneol=native#text/plain
+packages/fcl-js/examples/fpjsmin.pp svneol=native#text/plain
 packages/fcl-js/fpmake.pp svneol=native#text/plain
 packages/fcl-js/src/jsbase.pp svneol=native#text/plain
+packages/fcl-js/src/jsminifier.pp svneol=native#text/plain
 packages/fcl-js/src/jsparser.pp svneol=native#text/plain
 packages/fcl-js/src/jsscanner.pp svneol=native#text/plain
+packages/fcl-js/src/jssrcmap.pas svneol=native#text/plain
 packages/fcl-js/src/jstoken.pp svneol=native#text/plain
 packages/fcl-js/src/jstree.pp svneol=native#text/plain
 packages/fcl-js/src/jswriter.pp svneol=native#text/plain
 packages/fcl-js/tests/tcparser.pp svneol=native#text/plain
 packages/fcl-js/tests/tcscanner.pp svneol=native#text/plain
+packages/fcl-js/tests/tcsrcmap.pas svneol=native#text/plain
 packages/fcl-js/tests/tcwriter.pp svneol=native#text/plain
 packages/fcl-js/tests/testjs.ico -text
 packages/fcl-js/tests/testjs.lpi svneol=native#text/plain
@@ -2483,13 +2491,17 @@ packages/fcl-json/fpmake.pp svneol=native#text/plain
 packages/fcl-json/src/README.txt svneol=native#text/plain
 packages/fcl-json/src/fpjson.pp svneol=native#text/plain
 packages/fcl-json/src/fpjsonrtti.pp svneol=native#text/plain
+packages/fcl-json/src/fpjsontopas.pp svneol=native#text/plain
 packages/fcl-json/src/jsonconf.pp svneol=native#text/plain
 packages/fcl-json/src/jsonparser.pp svneol=native#text/plain
 packages/fcl-json/src/jsonscanner.pp svneol=native#text/plain
 packages/fcl-json/tests/jsonconftest.pp svneol=native#text/plain
+packages/fcl-json/tests/tcjsontocode.pp svneol=native#text/plain
 packages/fcl-json/tests/testcomps.pp svneol=native#text/plain
 packages/fcl-json/tests/testjson.lpi svneol=native#text/plain
 packages/fcl-json/tests/testjson.pp svneol=native#text/plain
+packages/fcl-json/tests/testjson2code.lpi svneol=native#text/plain
+packages/fcl-json/tests/testjson2code.lpr svneol=native#text/plain
 packages/fcl-json/tests/testjsonconf.lpi svneol=native#text/plain
 packages/fcl-json/tests/testjsonconf.pp svneol=native#text/plain
 packages/fcl-json/tests/testjsondata.pp svneol=native#text/plain
@@ -2533,12 +2545,16 @@ packages/fcl-net/src/win/resolve.inc svneol=native#text/plain
 packages/fcl-passrc/Makefile svneol=native#text/plain
 packages/fcl-passrc/Makefile.fpc svneol=native#text/plain
 packages/fcl-passrc/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/fcl-passrc/examples/parsepp.pp svneol=native#text/plain
 packages/fcl-passrc/examples/test_parser.pp svneol=native#text/plain
 packages/fcl-passrc/examples/testunit1.pp svneol=native#text/plain
 packages/fcl-passrc/fpmake.pp svneol=native#text/plain
+packages/fcl-passrc/src/pasresolveeval.pas svneol=native#text/plain
+packages/fcl-passrc/src/pasresolver.pp svneol=native#text/plain
 packages/fcl-passrc/src/passrcutil.pp svneol=native#text/plain
 packages/fcl-passrc/src/pastounittest.pp svneol=native#text/plain
 packages/fcl-passrc/src/pastree.pp svneol=native#text/plain
+packages/fcl-passrc/src/pasuseanalyzer.pas svneol=native#text/plain
 packages/fcl-passrc/src/paswrite.pp svneol=native#text/plain
 packages/fcl-passrc/src/pparser.pp svneol=native#text/plain
 packages/fcl-passrc/src/pscanner.pp svneol=native#text/plain
@@ -2546,13 +2562,16 @@ packages/fcl-passrc/src/readme.txt svneol=native#text/plain
 packages/fcl-passrc/tests/tcbaseparser.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcclasstype.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcexprparser.pas svneol=native#text/plain
+packages/fcl-passrc/tests/tcgenerics.pp svneol=native#text/plain
 packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcpassrcutil.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcprocfunc.pas svneol=native#text/plain
+packages/fcl-passrc/tests/tcresolver.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcscanner.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcstatements.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tctypeparser.pas svneol=native#text/plain
+packages/fcl-passrc/tests/tcuseanalyzer.pas svneol=native#text/plain
 packages/fcl-passrc/tests/tcvarparser.pas svneol=native#text/plain
 packages/fcl-passrc/tests/testpassrc.lpi svneol=native#text/plain
 packages/fcl-passrc/tests/testpassrc.lpr svneol=native#text/plain
@@ -2563,10 +2582,14 @@ packages/fcl-pdf/examples/testfppdf.lpi svneol=native#text/plain
 packages/fcl-pdf/examples/testfppdf.lpr svneol=native#text/plain
 packages/fcl-pdf/fpmake.pp svneol=native#text/plain
 packages/fcl-pdf/readme.txt svneol=native#text/plain
+packages/fcl-pdf/src/fontmetrics_stdpdf.inc svneol=native#text/plain
+packages/fcl-pdf/src/fpfonttextmapping.pp svneol=native#text/plain
 packages/fcl-pdf/src/fpparsettf.pp svneol=native#text/plain
 packages/fcl-pdf/src/fppdf.pp svneol=native#text/plain
 packages/fcl-pdf/src/fpttf.pp svneol=native#text/plain
 packages/fcl-pdf/src/fpttfencodings.pp svneol=native#text/plain
+packages/fcl-pdf/src/fpttfsubsetter.pp svneol=native#text/plain
+packages/fcl-pdf/tests/fontlist.txt svneol=native#text/plain
 packages/fcl-pdf/tests/fonts/README.txt svneol=native#text/plain
 packages/fcl-pdf/tests/fpparsettf_test.pas svneol=native#text/plain
 packages/fcl-pdf/tests/fppdf_test.pas svneol=native#text/plain
@@ -2577,8 +2600,6 @@ packages/fcl-pdf/tests/unittests_console.lpi svneol=native#text/plain
 packages/fcl-pdf/tests/unittests_console.lpr svneol=native#text/plain
 packages/fcl-pdf/tests/unittests_gui.lpi svneol=native#text/plain
 packages/fcl-pdf/tests/unittests_gui.lpr svneol=native#text/plain
-packages/fcl-pdf/utils/mkpdffontdef.lpi svneol=native#text/plain
-packages/fcl-pdf/utils/mkpdffontdef.pp svneol=native#text/plain
 packages/fcl-pdf/utils/ttfdump.lpi svneol=native#text/plain
 packages/fcl-pdf/utils/ttfdump.lpr svneol=native#text/plain
 packages/fcl-process/Makefile svneol=native#text/plain
@@ -2636,6 +2657,7 @@ packages/fcl-registry/src/xregreg.inc svneol=native#text/plain
 packages/fcl-registry/tests/Makefile svneol=native#text/plain
 packages/fcl-registry/tests/Makefile.fpc -text
 packages/fcl-registry/tests/regtestframework.pp -text
+packages/fcl-registry/tests/tcxmlreg.pp svneol=native#text/plain
 packages/fcl-registry/tests/testbasics.pp svneol=native#text/plain
 packages/fcl-registry/tests/tregistry2.pp svneol=native#text/plain
 packages/fcl-res/Makefile svneol=native#text/plain
@@ -3086,6 +3108,8 @@ packages/fcl-web/examples/httpclient/httppost.lpi svneol=native#text/plain
 packages/fcl-web/examples/httpclient/httppost.pp svneol=native#text/plain
 packages/fcl-web/examples/httpclient/httppostfile.lpi svneol=native#text/plain
 packages/fcl-web/examples/httpclient/httppostfile.pp svneol=native#text/plain
+packages/fcl-web/examples/httpclient/keepalive.lpi svneol=native#text/plain
+packages/fcl-web/examples/httpclient/keepalive.pp svneol=native#text/plain
 packages/fcl-web/examples/httpserver/simplehttpserver.lpi svneol=native#text/plain
 packages/fcl-web/examples/httpserver/simplehttpserver.pas svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/README.txt svneol=native#text/plain
@@ -3104,10 +3128,20 @@ packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpr svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/extdirect/extdirect.in svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp svneol=native#text/plain
+packages/fcl-web/examples/routing/README svneol=native#text/plain
+packages/fcl-web/examples/routing/demorouting.lpi svneol=native#text/plain
+packages/fcl-web/examples/routing/demorouting.lpr svneol=native#text/plain
+packages/fcl-web/examples/routing/routes.pp svneol=native#text/plain
+packages/fcl-web/examples/routing/sample.ini svneol=native#text/plain
 packages/fcl-web/examples/session/sessiondemo.lpi svneol=native#text/plain
 packages/fcl-web/examples/session/sessiondemo.lpr svneol=native#text/plain
 packages/fcl-web/examples/session/wmsession.lfm svneol=native#text/plain
 packages/fcl-web/examples/session/wmsession.pp svneol=native#text/plain
+packages/fcl-web/examples/simpleserver/README.txt svneol=native#text/plain
+packages/fcl-web/examples/simpleserver/index.css svneol=native#text/plain
+packages/fcl-web/examples/simpleserver/index.html svneol=native#text/plain
+packages/fcl-web/examples/simpleserver/simpleserver.lpi svneol=native#text/plain
+packages/fcl-web/examples/simpleserver/simpleserver.pas svneol=native#text/plain
 packages/fcl-web/examples/webdata/demo/createusers.lpi svneol=native#text/plain
 packages/fcl-web/examples/webdata/demo/createusers.lpr svneol=native#text/plain
 packages/fcl-web/examples/webdata/demo/extgrid-json.html svneol=native#text/plain
@@ -3205,9 +3239,11 @@ packages/fcl-web/src/base/fpwebclient.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain
 packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
 packages/fcl-web/src/base/httpprotocol.pp svneol=native#text/plain
+packages/fcl-web/src/base/httproute.pp svneol=native#text/plain
 packages/fcl-web/src/base/iniwebsession.pp svneol=native#text/plain
 packages/fcl-web/src/base/restbase.pp svneol=native#text/plain
 packages/fcl-web/src/base/restcodegen.pp svneol=native#text/plain
+packages/fcl-web/src/base/tcwebmodule.pp svneol=native#text/plain
 packages/fcl-web/src/base/webpage.pp svneol=native#text/plain
 packages/fcl-web/src/base/websession.pp svneol=native#text/plain
 packages/fcl-web/src/base/webutil.pp svneol=native#text/plain
@@ -3234,8 +3270,11 @@ packages/fcl-web/tests/cgigateway.lpi svneol=native#text/plain
 packages/fcl-web/tests/cgigateway.pp svneol=native#text/plain
 packages/fcl-web/tests/fpcunithpack.lpi svneol=native#text/plain
 packages/fcl-web/tests/fpcunithpack.lpr svneol=native#text/plain
+packages/fcl-web/tests/tchttproute.pp svneol=native#text/plain
 packages/fcl-web/tests/testcgiapp.lpi svneol=native#text/plain
 packages/fcl-web/tests/testcgiapp.pp svneol=native#text/plain
+packages/fcl-web/tests/testfpweb.lpi svneol=native#text/plain
+packages/fcl-web/tests/testfpweb.lpr svneol=native#text/plain
 packages/fcl-web/tests/uhpacktest1.pas svneol=native#text/plain
 packages/fcl-xml/Makefile svneol=native#text/plain
 packages/fcl-xml/Makefile.fpc svneol=native#text/plain
@@ -6518,6 +6557,8 @@ packages/pastojs/Makefile.fpc svneol=native#text/plain
 packages/pastojs/fpmake.pp svneol=native#text/plain
 packages/pastojs/src/fppas2js.pp svneol=native#text/plain
 packages/pastojs/tests/tcconverter.pp svneol=native#text/plain
+packages/pastojs/tests/tcmodules.pas svneol=native#text/plain
+packages/pastojs/tests/tcoptimizations.pas svneol=native#text/plain
 packages/pastojs/tests/testpas2js.lpi svneol=native#text/plain
 packages/pastojs/tests/testpas2js.pp svneol=native#text/plain
 packages/pastojs/todo.txt svneol=native#text/plain
@@ -6559,6 +6600,7 @@ packages/paszlib/src/ziputils.pas svneol=native#text/plain
 packages/paszlib/src/zstream.pp svneol=native#text/plain
 packages/paszlib/src/zuncompr.pas svneol=native#text/plain
 packages/paszlib/tests/tczipper.pp svneol=native#text/plain
+packages/paszlib/tests/tczstreamseek.pp svneol=native#text/plain
 packages/pcap/Makefile svneol=native#text/plain
 packages/pcap/Makefile.fpc svneol=native#text/plain
 packages/pcap/Makefile.fpc.fpcmake svneol=native#text/plain
@@ -6710,7 +6752,6 @@ packages/ptc/src/core/surfaced.inc svneol=native#text/plain
 packages/ptc/src/core/surfacei.inc svneol=native#text/plain
 packages/ptc/src/core/timerd.inc svneol=native#text/plain
 packages/ptc/src/core/timeri.inc svneol=native#text/plain
-packages/ptc/src/dos/base/go32fix.pp svneol=native#text/plain
 packages/ptc/src/dos/base/kbd.inc svneol=native#text/plain
 packages/ptc/src/dos/base/kbdd.inc svneol=native#text/plain
 packages/ptc/src/dos/base/mouse33h.pp svneol=native#text/plain
@@ -6731,6 +6772,8 @@ packages/ptc/src/dos/vga/vga.pp svneol=native#text/plain
 packages/ptc/src/dos/vga/vgaconsoled.inc svneol=native#text/plain
 packages/ptc/src/dos/vga/vgaconsolei.inc svneol=native#text/plain
 packages/ptc/src/ptc.pp svneol=native#text/plain
+packages/ptc/src/ptclaz.lpi svneol=native#text/plain
+packages/ptc/src/ptclaz.lpr svneol=native#text/plain
 packages/ptc/src/ptcpas.cfg svneol=native#text/plain
 packages/ptc/src/ptcwrapper/ptceventqueue.pp svneol=native#text/plain
 packages/ptc/src/ptcwrapper/ptcwrapper.pp svneol=native#text/plain
@@ -6756,6 +6799,7 @@ packages/ptc/src/win32/base/win32window.inc svneol=native#text/plain
 packages/ptc/src/win32/base/win32windowd.inc svneol=native#text/plain
 packages/ptc/src/win32/base/windows.ico -text
 packages/ptc/src/win32/directx/p_ddraw.pp svneol=native#text/plain
+packages/ptc/src/win32/directx/p_dinput.pp svneol=native#text/plain
 packages/ptc/src/win32/directx/win32directxcheck.inc svneol=native#text/plain
 packages/ptc/src/win32/directx/win32directxconsoled.inc svneol=native#text/plain
 packages/ptc/src/win32/directx/win32directxconsolei.inc svneol=native#text/plain
@@ -6814,7 +6858,13 @@ packages/ptc/src/x11/x11unikey.inc svneol=native#text/plain
 packages/ptc/src/x11/x11windowdisplayd.inc svneol=native#text/plain
 packages/ptc/src/x11/x11windowdisplayi.inc svneol=native#text/plain
 packages/ptc/tests/convtest.pp svneol=native#text/plain
+packages/ptc/tests/crtkeys/crtkeys.pas svneol=native#text/plain
+packages/ptc/tests/crtkeys/crtkeys_fpwincrt.txt svneol=native#text/plain
+packages/ptc/tests/crtkeys/crtkeys_go32v2.txt svneol=native#text/plain
+packages/ptc/tests/crtkeys/crtkeys_tp7.txt svneol=native#text/plain
+packages/ptc/tests/crtkeys/ptccrtkeys.pas svneol=native#text/plain
 packages/ptc/tests/endian.inc svneol=native#text/plain
+packages/ptc/tests/event.pp svneol=native#text/plain
 packages/ptc/tests/view.pp svneol=native#text/plain
 packages/pthreads/Makefile svneol=native#text/plain
 packages/pthreads/Makefile.fpc svneol=native#text/plain
@@ -8003,14 +8053,18 @@ packages/x11/Makefile.fpc svneol=native#text/plain
 packages/x11/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/x11/fpmake.pp svneol=native#text/plain
 packages/x11/src/cursorfont.pp svneol=native#text/plain
+packages/x11/src/deckeysym.pp svneol=native#text/plain
 packages/x11/src/fontconfig.pas svneol=native#text/pascal
+packages/x11/src/hpkeysym.pp svneol=native#text/plain
 packages/x11/src/keysym.pp svneol=native#text/plain
 packages/x11/src/randr.inc svneol=native#text/plain
+packages/x11/src/sunkeysym.pp svneol=native#text/plain
 packages/x11/src/x.pp svneol=native#text/plain
 packages/x11/src/xatom.pp svneol=native#text/plain
 packages/x11/src/xcms.pp svneol=native#text/plain
 packages/x11/src/xf86dga.pp svneol=native#text/plain
 packages/x11/src/xf86dga1.inc svneol=native#text/plain
+packages/x11/src/xf86keysym.pp svneol=native#text/plain
 packages/x11/src/xf86vmode.pp svneol=native#text/plain
 packages/x11/src/xfixes.pp svneol=native#text/plain
 packages/x11/src/xfixeswire.inc svneol=native#text/plain
@@ -8509,6 +8563,7 @@ rtl/gba/gbabiosh.inc svneol=native#text/plain
 rtl/gba/libc.inc svneol=native#text/plain
 rtl/gba/libch.inc svneol=native#text/plain
 rtl/gba/prt0.as svneol=native#text/plain
+rtl/gba/rtl.cfg svneol=native#text/plain
 rtl/gba/rtldefs.inc svneol=native#text/plain
 rtl/gba/sysdir.inc svneol=native#text/plain
 rtl/gba/sysfile.inc svneol=native#text/plain
@@ -8576,7 +8631,6 @@ rtl/haiku/suuid.inc svneol=native#text/plain
 rtl/haiku/syscall.inc svneol=native#text/plain
 rtl/haiku/syscallh.inc svneol=native#text/plain
 rtl/haiku/sysconst.inc svneol=native#text/plain
-rtl/haiku/sysheap.inc svneol=native#text/plain
 rtl/haiku/sysnr.inc svneol=native#text/plain
 rtl/haiku/sysos.inc svneol=native#text/plain
 rtl/haiku/sysosh.inc svneol=native#text/plain
@@ -10658,6 +10712,7 @@ tests/tbs/tb0607.pp svneol=native#text/plain
 tests/tbs/tb0608.pp svneol=native#text/pascal
 tests/tbs/tb0609.pp svneol=native#text/plain
 tests/tbs/tb0618.pp svneol=native#text/plain
+tests/tbs/tb0621.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tb613.pp svneol=native#text/plain
@@ -14605,6 +14660,8 @@ tests/webtbs/tw2865.pp svneol=native#text/plain
 tests/webtbs/tw28650.pp svneol=native#text/pascal
 tests/webtbs/tw28674.pp svneol=native#text/pascal
 tests/webtbs/tw28702.pp svneol=native#text/plain
+tests/webtbs/tw28713.pp svneol=native#text/pascal
+tests/webtbs/tw28713b.pp svneol=native#text/pascal
 tests/webtbs/tw28718a.pp svneol=native#text/plain
 tests/webtbs/tw28718b.pp svneol=native#text/plain
 tests/webtbs/tw28718c.pp svneol=native#text/plain
@@ -14678,7 +14735,9 @@ tests/webtbs/tw3012.pp svneol=native#text/plain
 tests/webtbs/tw30166.pp svneol=native#text/plain
 tests/webtbs/tw30207.pp svneol=native#text/plain
 tests/webtbs/tw3023.pp svneol=native#text/plain
+tests/webtbs/tw30240.pp svneol=native#text/plain
 tests/webtbs/tw3028.pp svneol=native#text/plain
+tests/webtbs/tw30357.pp svneol=native#text/pascal
 tests/webtbs/tw3038.pp svneol=native#text/plain
 tests/webtbs/tw3041.pp svneol=native#text/plain
 tests/webtbs/tw3045.pp svneol=native#text/plain
@@ -15507,6 +15566,16 @@ utils/fpdoc/dw_txt.pp svneol=native#text/plain
 utils/fpdoc/dw_xml.pp svneol=native#text/plain
 utils/fpdoc/dwlinear.pp svneol=native#text/plain
 utils/fpdoc/dwriter.pp svneol=native#text/plain
+utils/fpdoc/examples/basedir/readme.txt svneol=native#text/plain
+utils/fpdoc/examples/basedir/sample-project.xml svneol=native#text/plain
+utils/fpdoc/examples/gentest.sh svneol=native#text/plain
+utils/fpdoc/examples/project/readme.txt svneol=native#text/plain
+utils/fpdoc/examples/project/sample-project.xml svneol=native#text/plain
+utils/fpdoc/examples/simple/html.bat svneol=native#text/plain
+utils/fpdoc/examples/simple/html.sh svneol=native#text/plain
+utils/fpdoc/examples/simple/readme.txt svneol=native#text/plain
+utils/fpdoc/examples/simple/testunit.pp svneol=native#text/plain
+utils/fpdoc/examples/simple/testunit.xml svneol=native#text/plain
 utils/fpdoc/fpclasschart.lpi svneol=native#text/plain
 utils/fpdoc/fpclasschart.pp svneol=native#text/plain
 utils/fpdoc/fpde/Makefile svneol=native#text/plain
@@ -15548,7 +15617,6 @@ utils/fpdoc/fpdocstripper.lpi svneol=native#text/plain
 utils/fpdoc/fpdocstripper.pp svneol=native#text/plain
 utils/fpdoc/fpdocxmlopts.pas svneol=native#text/plain
 utils/fpdoc/fpmake.pp svneol=native#text/plain
-utils/fpdoc/gentest.sh svneol=native#text/plain
 utils/fpdoc/images/minus.png -text svneol=unset#image/png
 utils/fpdoc/images/plus.png -text svneol=unset#image/png
 utils/fpdoc/intl/Makefile svneol=native#text/plain
@@ -15569,8 +15637,6 @@ utils/fpdoc/mkfpdocproj.pp svneol=native#text/plain
 utils/fpdoc/plusimage.inc svneol=native#text/plain
 utils/fpdoc/sample-project.xml svneol=native#text/plain
 utils/fpdoc/sh_pas.pp svneol=native#text/plain
-utils/fpdoc/testunit.pp svneol=native#text/plain
-utils/fpdoc/testunit.xml svneol=native#text/plain
 utils/fpdoc/unitdiff.pp svneol=native#text/plain
 utils/fpgmake/fpgmake.pp svneol=native#text/plain
 utils/fpgmake/fpmake.cft svneol=native#text/plain
@@ -15747,6 +15813,7 @@ utils/pas2jni/readme.txt svneol=native#text/plain
 utils/pas2jni/writer.pas svneol=native#text/plain
 utils/pas2js/Makefile svneol=native#text/plain
 utils/pas2js/Makefile.fpc svneol=native#text/plain
+utils/pas2js/dist/rtl.js svneol=native#text/plain
 utils/pas2js/fpmake.pp svneol=native#text/plain
 utils/pas2js/pas2js.lpi svneol=native#text/plain
 utils/pas2js/pas2js.pp svneol=native#text/plain

Makefile

@@ -475,7 +475,7 @@ endif
 endif
 BuildOnlyBaseCPUs=jvm
 ifneq ($(wildcard utils),)
-NOUTILSTARGETS=embedded gba msdos $(BuildOnlyBaseCPUs)
+NOUTILSTARGETS=embedded gba nds msdos $(BuildOnlyBaseCPUs)
 ifeq ($(findstring $(OS_TARGET),$(NOUTILSTARGETS)),)
 ifdef BUILDFULLNATIVE
 UTILS=1

Makefile.fpc

@@ -206,7 +206,7 @@ endif
 BuildOnlyBaseCPUs=jvm
 
 ifneq ($(wildcard utils),)
-NOUTILSTARGETS=embedded gba msdos $(BuildOnlyBaseCPUs)
+NOUTILSTARGETS=embedded gba nds msdos $(BuildOnlyBaseCPUs)
 ifeq ($(findstring $(OS_TARGET),$(NOUTILSTARGETS)),)
 ifdef BUILDFULLNATIVE
 UTILS=1

compiler/COPYING.txt

@@ -305,7 +305,7 @@ the "copyright" line and a pointer to where the full notice is found.
 
     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
-    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 
 
 Also add information on how to contact you by electronic and paper mail.

compiler/Makefile

@@ -557,6 +557,9 @@ endif
 ifeq ($(OS_TARGET),msdos)
 NoNativeBinaries=1
 endif
+ifeq ($(OS_TARGET),nds)
+NoNativeBinaries=1
+endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_DIRS+=utils
 endif
@@ -4146,13 +4149,11 @@ cycle:
 	$(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2
 ifndef CROSSINSTALL
 	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl CYCLELEVEL=3
-ifneq ($(OS_TARGET),embedded)
-ifneq ($(OS_TARGET),gba)
+ifndef NoNativeBinaries
 	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler CYCLELEVEL=3
 endif
 endif
 endif
-endif
 else
 cycle: override FPC=
 cycle:

compiler/Makefile.fpc

@@ -329,6 +329,9 @@ endif
 ifeq ($(OS_TARGET),msdos)
 NoNativeBinaries=1
 endif
+ifeq ($(OS_TARGET),nds)
+NoNativeBinaries=1
+endif
 
 [rules]
 #####################################################################
@@ -688,14 +691,10 @@ cycle:
 # ppc<ARCH> (target native)
 ifndef CROSSINSTALL
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl CYCLELEVEL=3
-# building a native compiler for embedded targets is not possible
-ifneq ($(OS_TARGET),embedded)
-# building a native compiler for the arm-gba target is not possible
-ifneq ($(OS_TARGET),gba)
+ifndef NoNativeBinaries
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler CYCLELEVEL=3
 endif
 endif
-endif
 
 endif
 
@@ -721,7 +720,6 @@ cycle:
 # ppc<ARCH> (target native)
 ifndef CROSSINSTALL
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(RTLOPT) $(CROSSOPT)' rtlclean rtl CYCLELEVEL=3
-# building a native compiler for JVM and embedded targets is not possible
 ifndef NoNativeBinaries
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(strip $(LOCALOPT) $(CROSSOPT))' cycleclean compiler CYCLELEVEL=3
 endif

compiler/arm/aoptcpu.pas

@@ -2500,13 +2500,14 @@ Implementation
               hp3:=tai(p.Previous);
               hp5:=tai(p.next);
               asml.Remove(p);
-              { if there is a reg. dealloc instruction or address labels (e.g. for GOT-less PIC)
+              { if there is a reg. alloc/dealloc/sync instructions or address labels (e.g. for GOT-less PIC)
                 associated with p, move it together with p }
 
               { before the instruction? }
+              { find reg allocs,deallocs and PIC labels }
               while assigned(hp3) and (hp3.typ<>ait_instruction) do
                 begin
-                  if ( (hp3.typ=ait_regalloc) and (tai_regalloc(hp3).ratype in [ra_dealloc]) and
+                  if ( (hp3.typ=ait_regalloc) and (tai_regalloc(hp3).ratype in [ra_alloc, ra_dealloc]) and
                     RegInInstruction(tai_regalloc(hp3).reg,p) )
                     or ( (hp3.typ=ait_label) and (tai_label(hp3).labsym.typ=AT_ADDR) )
                   then
@@ -2514,7 +2515,7 @@ Implementation
                       hp4:=hp3;
                       hp3:=tai(hp3.Previous);
                       asml.Remove(hp4);
-                      list.Concat(hp4);
+                      list.Insert(hp4);
                     end
                   else
                     hp3:=tai(hp3.Previous);
@@ -2524,9 +2525,10 @@ Implementation
               SwapRegLive(taicpu(p),taicpu(hp1));
 
               { after the instruction? }
+              { find reg deallocs and reg syncs }
               while assigned(hp5) and (hp5.typ<>ait_instruction) do
                 begin
-                  if (hp5.typ=ait_regalloc) and (tai_regalloc(hp5).ratype in [ra_dealloc]) and
+                  if (hp5.typ=ait_regalloc) and (tai_regalloc(hp5).ratype in [ra_dealloc, ra_sync]) and
                     RegInInstruction(tai_regalloc(hp5).reg,p) then
                     begin
                       hp4:=hp5;

compiler/assemble.pas

@@ -1583,7 +1583,7 @@ Implementation
            MaybeNextList(hp);
          end;
         ObjData.afteralloc;
-        { leave if errors have occured }
+        { leave if errors have occurred }
         if errorcount>0 then
          goto doexit;
 
@@ -1604,7 +1604,7 @@ Implementation
         ObjData.createsection(sec_code);
         ObjData.afteralloc;
 
-        { leave if errors have occured }
+        { leave if errors have occurred }
         if errorcount>0 then
          goto doexit;
 
@@ -1625,7 +1625,7 @@ Implementation
         ObjData.createsection(sec_code);
         ObjData.afterwrite;
 
-        { don't write the .o file if errors have occured }
+        { don't write the .o file if errors have occurred }
         if errorcount=0 then
          begin
            { write objectfile }
@@ -1672,7 +1672,7 @@ Implementation
            ObjData.createsection(startsectype);
            TreePass0(hp);
            ObjData.afteralloc;
-           { leave if errors have occured }
+           { leave if errors have occurred }
            if errorcount>0 then
              break;
 
@@ -1684,7 +1684,7 @@ Implementation
            TreePass1(hp);
            ObjData.afteralloc;
 
-           { leave if errors have occured }
+           { leave if errors have occurred }
            if errorcount>0 then
              break;
 
@@ -1697,7 +1697,7 @@ Implementation
            hp:=TreePass2(hp);
            ObjData.afterwrite;
 
-           { leave if errors have occured }
+           { leave if errors have occurred }
            if errorcount>0 then
              break;
 

compiler/dbgdwarf.pas

@@ -3112,6 +3112,7 @@ implementation
         dbgname: string;
         vardatatype: ttypesym;
         bind: tasmsymbind;
+        lang: tdwarf_source_language;
       begin
         current_module.flags:=current_module.flags or uf_has_dwarf_debuginfo;
         storefilepos:=current_filepos;
@@ -3160,12 +3161,16 @@ implementation
         { address size }
         current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_8bit(sizeof(pint)));
 
+        if (ds_dwarf_cpp in current_settings.debugswitches) then
+          lang:=DW_LANG_C_plus_plus
+        else
+          lang:=DW_LANG_Pascal83;
         { first manadatory compilation unit TAG }
         append_entry(DW_TAG_compile_unit,true,[
           DW_AT_name,DW_FORM_string,relative_dwarf_path(current_module.sourcefiles.get_file(1).path+current_module.sourcefiles.get_file(1).name)+#0,
           DW_AT_producer,DW_FORM_string,'Free Pascal '+full_version_string+' '+date_string+#0,
           DW_AT_comp_dir,DW_FORM_string,BSToSlash(FixPath(GetCurrentDir,false))+#0,
-          DW_AT_language,DW_FORM_data1,DW_LANG_Pascal83,
+          DW_AT_language,DW_FORM_data1,lang,
           DW_AT_identifier_case,DW_FORM_data1,DW_ID_case_insensitive]);
 
         { reference to line info section }
@@ -3989,8 +3994,16 @@ implementation
 
     procedure TDebugInfoDwarf3.appenddef_formal(list:TAsmList;def: tformaldef);
       begin
-        append_entry(DW_TAG_unspecified_type,false,[
-          ]);
+        if (ds_dwarf_cpp in current_settings.debugswitches) then
+          begin
+            // Do not use DW_TAG_unspecified_type for C++ simulation.
+            // At least LLDB 3.9.0 crashes in such case.
+            // Call the inherited DWARF 2 implementation, which works fine.
+            inherited;
+            exit;
+          end;
+
+        append_entry(DW_TAG_unspecified_type,false,[]);
         finish_entry;
       end;
 

compiler/globtype.pas

@@ -215,7 +215,10 @@ interface
           { for Stabs); not enabled by default, because otherwise once  }
           { support for calling methods has been added to gdb, you'd    }
           { always have to type classinstance.classname__methodname()   }
-          ds_dwarf_method_class_prefix
+          ds_dwarf_method_class_prefix,
+          { Simulate C++ debug information in DWARF. It can be used for }
+          { debuggers, which do not support Pascal.                     }
+          ds_dwarf_cpp
        );
        tdebugswitches = set of tdebugswitch;
 
@@ -327,7 +330,7 @@ interface
        );
 
        DebugSwitchStr : array[tdebugswitch] of string[22] = ('',
-         'DWARFSETS','STABSABSINCLUDES','DWARFMETHODCLASSPREFIX');
+         'DWARFSETS','STABSABSINCLUDES','DWARFMETHODCLASSPREFIX','DWARFCPP');
 
        TargetSwitchStr : array[ttargetswitch] of ttargetswitchinfo = (
          (name: '';                    hasvalue: false; isglobal: true ; define: ''),

compiler/i386/popt386.pas

@@ -74,8 +74,12 @@ begin
   UpdateUsedRegs(UsedRegs, tai(p.Next));
   RegUsedAfterInstruction :=
     (supreg in UsedRegs) and
-    (not(getNextInstruction(p,p)) or
-     not(regLoadedWithNewValue(supreg,false,p)));
+    not(regLoadedWithNewValue(supreg,false,p)) and
+    (
+      not(GetNextInstruction(p,p)) or
+      RegReadByInstruction(supreg,p) or
+      not(regLoadedWithNewValue(supreg,false,p))
+    );
 end;
 
 

compiler/msg/errore.msg

@@ -3599,6 +3599,7 @@ J*2Cv_Var/out parameter copy-out checking
 *g3godwarfsets_ Enable DWARF 'set' type debug information (breaks gdb < 6.5)
 *g3gostabsabsincludes_ Store absolute/full include file paths in Stabs
 *g3godwarfmethodclassprefix_ Prefix method names in DWARF with class name
+*g3godwarfcpp_ Simulate C++ debug information in DWARF
 *g2gp_Preserve case in stabs symbol names
 *g2gs_Generate Stabs debug information
 *g2gt_Trash local variables (to detect uninitialized uses; multiple 't' changes the trashing value)

compiler/msgtxt.inc

@@ -1223,7 +1223,7 @@ const msgtxt : array[0..000312,1..240] of char=(
   'le "$1"'#000+
   '11023_Free Pascal Compiler version $FPCFULLVERSION [$FPC','DATE] for $F'+
   'PCCPU'#010+
-  'Copyright (c) 1993-2015 by Florian Klaempfl and others'#000+
+  'Copyright (c) 1993-2017 by Florian Klaempfl and others'#000+
   '11024_Free Pascal Compiler version $FPCVERSION'#010+
   #010+
   'Compiler date      : $FPCDATE'#010+

compiler/nadd.pas

@@ -697,8 +697,12 @@ implementation
           an slash expresion would be first converted into a multiplication and later
           folded }
         if (nodetype=slashn) and
-          { do not mess with currency types }
-          (not(is_currency(right.resultdef))) and
+          { do not mess with currency and comp types }
+          (not(is_currency(right.resultdef)) and
+           not((right.resultdef.typ=floatdef) and
+               (tfloatdef(right.resultdef).floattype=s64comp)
+              )
+          ) and
           (((cs_opt_fastmath in current_settings.optimizerswitches) and (rt=ordconstn)) or
            ((cs_opt_fastmath in current_settings.optimizerswitches) and (rt=realconstn) and
             (bestrealrec(trealconstnode(right).value_real).SpecialType in [fsPositive,fsNegative])

compiler/ncgrtti.pas

@@ -652,6 +652,7 @@ implementation
                write_rtti_reference(def.elementdef,rt);
                { variant type }
                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(tstoreddef(def.elementdef).getvardef));
+               maybe_write_align;
                { element type }
                if def.elementdef.needs_inittable then
                  write_rtti_reference(def.elementdef,rt)

compiler/nmem.pas

@@ -774,6 +774,10 @@ implementation
     procedure Tsubscriptnode.mark_write;
       begin
         include(flags,nf_write);
+        { if an element of a record is written, then the whole record is changed/it is written to it,
+          for data types being implicit pointers this does not apply as the object itself does not change }
+        if not(is_implicit_pointer_object_type(left.resultdef)) then
+          left.mark_write;
       end;
 
 
@@ -1077,6 +1081,9 @@ implementation
     procedure Tvecnode.mark_write;
       begin
         include(flags,nf_write);
+        { see comment in tsubscriptnode.mark_write }
+        if not(is_implicit_pointer_object_type(left.resultdef)) then
+          left.mark_write;
       end;
 
 

compiler/pmodules.pas

@@ -620,12 +620,12 @@ implementation
         case flag of
           uf_init :
             begin
-              result:=create_main_proc(make_mangledname('',current_module.localsymtable,'init_implicit'),potype_unitinit,st);
+              result:=create_main_proc(make_mangledname('',current_module.localsymtable,'init_implicit$'),potype_unitinit,st);
               result.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
             end;
           uf_finalize :
             begin
-              result:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize_implicit'),potype_unitfinalize,st);
+              result:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize_implicit$'),potype_unitfinalize,st);
               result.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
               if (not current_module.is_unit) then
                 result.procdef.aliasnames.insert('PASCALFINALIZE');
@@ -952,7 +952,7 @@ type
                internalerror(200212285);
 
              { Compile the unit }
-             init_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'init'),potype_unitinit,current_module.localsymtable);
+             init_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'init$'),potype_unitinit,current_module.localsymtable);
              init_procinfo.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
              init_procinfo.parse_body;
              { save file pos for debuginfo }
@@ -1084,7 +1084,7 @@ type
          if not current_module.interface_only and (token=_FINALIZATION) then
            begin
               { Compile the finalize }
-              finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize'),potype_unitfinalize,current_module.localsymtable);
+              finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize$'),potype_unitfinalize,current_module.localsymtable);
               finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
               finalize_procinfo.parse_body;
            end
@@ -2150,7 +2150,7 @@ type
          if token=_FINALIZATION then
            begin
               { Parse the finalize }
-              finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize'),potype_unitfinalize,current_module.localsymtable);
+              finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize$'),potype_unitfinalize,current_module.localsymtable);
               finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
               finalize_procinfo.procdef.aliasnames.insert('PASCALFINALIZE');
               finalize_procinfo.parse_body;

compiler/powerpc/agppcmpw.pas

@@ -125,7 +125,7 @@ interface
       t32bitarray = array[0..3] of byte;
 
     function ReplaceForbiddenChars(var s: string):Boolean;
-         {Returns wheater a replacement has occured.}
+         {Returns wheater a replacement has occurred.}
 
         var
           i:Integer;

compiler/powerpc/cgcpu.pas

@@ -771,7 +771,7 @@ const
      { one.                                                                     }
      { This procedure may be called before, as well as after g_return_from_proc }
      { is called. NOTE registers are not to be allocated through the register   }
-     { allocator here, because the register colouring has already occured !!    }
+     { allocator here, because the register colouring has already occurred !!    }
 
 
      var regcounter,firstregfpu,firstregint: TSuperRegister;
@@ -920,7 +920,7 @@ const
     procedure tcgppc.g_proc_exit(list : TAsmList;parasize : longint;nostackframe:boolean);
      { This procedure may be called before, as well as after g_stackframe_entry }
      { is called. NOTE registers are not to be allocated through the register   }
-     { allocator here, because the register colouring has already occured !!    }
+     { allocator here, because the register colouring has already occurred !!    }
 
       var
          regcounter,firstregfpu,firstregint: TsuperRegister;

compiler/powerpc64/cgcpu.pas

@@ -1099,7 +1099,7 @@ end;
  called by the current one
 
  IMPORTANT: registers are not to be allocated through the register
- allocator here, because the register colouring has already occured !!
+ allocator here, because the register colouring has already occurred !!
 }
 procedure tcgppc.g_proc_entry(list: TAsmList; localsize: longint;
   nostackframe: boolean);
@@ -1239,7 +1239,7 @@ end;
  is called.
 
  IMPORTANT: registers are not to be allocated through the register
- allocator here, because the register colouring has already occured !!
+ allocator here, because the register colouring has already occurred !!
 }
 procedure tcgppc.g_proc_exit(list: TAsmList; parasize: longint; nostackframe:
   boolean);

compiler/ppu.pas

@@ -827,7 +827,7 @@ begin
 {$elseif defined(cpu32bitaddr)}
   result:=getlongint;
 {$elseif defined(cpu16bitaddr)}
-  result:=getword;
+  result:=asizeint(getword);
 {$endif}
 {$endif not generic_cpu}
 end;

compiler/script.pas

@@ -269,10 +269,10 @@ Begin
   AddStart('@echo off');
   Add('goto end');
   Add(':asmend');
-  Add('echo An error occured while assembling %THEFILE%');
+  Add('echo An error occurred while assembling %THEFILE%');
   Add('goto end');
   Add(':linkend');
-  Add('echo An error occured while linking %THEFILE%');
+  Add('echo An error occurred while linking %THEFILE%');
   Add(':end');
   inherited WriteToDisk;
 end;
@@ -336,11 +336,11 @@ Begin
   Add('skip end');
   Add('lab asmend');
   Add('why');
-  Add('echo An error occured while assembling $THEFILE');
+  Add('echo An error occurred while assembling $THEFILE');
   Add('skip end');
   Add('lab linkend');
   Add('why');
-  Add('echo An error occured while linking $THEFILE');
+  Add('echo An error occurred while linking $THEFILE');
   Add('lab end');
   inherited WriteToDisk;
 end;

compiler/symtable.pas

@@ -378,12 +378,14 @@ implementation
     procedure tstoredsymtable.insert(sym:TSymEntry;checkdup:boolean=true);
       begin
         inherited insert(sym,checkdup);
+        init_final_check_done:=false;
       end;
 
 
     procedure tstoredsymtable.delete(sym:TSymEntry);
       begin
         inherited delete(sym);
+        init_final_check_done:=false;
       end;
 
 
@@ -1708,7 +1710,7 @@ implementation
             { iso mode program parameters: staticvarsyms might have the same name as a program parameters,
               in this case, copy the isoindex and make the original symbol invisible }
             else if (m_iso in current_settings.modeswitches) and (hsym.typ=programparasym) and (sym.typ=staticvarsym)
-              and (tstaticvarsym(hsym).isoindex<>0) then
+              and (tprogramparasym(hsym).isoindex<>0) then
               begin
                 HideSym(hsym);
                 tstaticvarsym(sym).isoindex:=tprogramparasym(hsym).isoindex;

compiler/systems/i_morph.pas

@@ -66,7 +66,7 @@ unit i_morph;
             link         : ld_none;
             linkextern   : ld_morphos;
             ar           : ar_gnu_ar;
-            res          : res_none;
+            res          : res_elf;
             dbg          : dbg_stabs;
             script       : script_amiga;
             endian       : endian_big;

compiler/systems/t_morph.pas

@@ -31,7 +31,7 @@ implementation
 
     uses
        SysUtils,
-       cutils,cfileutl,cclasses,
+       cutils,cfileutl,cclasses,rescmn,comprsrc,
        globtype,globals,systems,verbose,script,fmodule,i_morph,link;
 
     type
@@ -265,4 +265,5 @@ end;
 initialization
   RegisterLinker(ld_morphos,TLinkerMorphOS);
   RegisterTarget(system_powerpc_morphos_info);
+  RegisterRes(res_elf_info, TWinLikeResourceFile);
 end.

installer/install.dat

@@ -142,6 +142,8 @@ package=utils-lexyaccdos.zip[tplydos.zip],Compiler generator for TP and compatib
 package=units-ptcdos.zip[uptcdos.zip],Free portable framebuffer library
 # Dos-2 23
 package=utils-dxegendos.zip[dxegdos.zip],Generation of D~X~E modules loadable at runtime
+# Dos-2 24
+package=ufcl-pdfdos.zip[ufcpddos.zip],PDF generating and TTF file info library
 
 #
 # Win32 packages
@@ -365,6 +367,8 @@ package=utils-pas2fpmos2.zip[p2fmos2.zip],Generate fpmake.pp for Pascal source
 package=utils-pas2jnios2.zip[p2jnos2.zip],Generate JNI bridge for Pascal code
 # OS/2 31
 package=utils-pas2utos2.zip[p2utos2.zip],Pascal source to FPC Unit test generator
+# OS/2 32
+package=ufcl-pdfos2.zip[ufcpdos2.zip],PDF generating and TTF file info library
 
 #
 # OS/2 packages 2nd part
@@ -527,6 +531,8 @@ package=utils-pas2fpmemx.zip[p2fmemx.zip],Generate fpmake.pp for Pascal source
 package=utils-pas2jniemx.zip[p2jnemx.zip],Generate JNI bridge for Pascal code
 # EMX 31
 package=utils-pas2utemx.zip[p2utemx.zip],Pascal source to FPC Unit test generator
+# EMX 32
+package=ufcl-pdfemx.zip[ufcpdemx.zip],PDF generating and TTF file info library
 
 #
 # EMX packages 2nd part
@@ -701,7 +707,7 @@ filecheck=*.source.zip[*src.zip]
 # Source-2 1
 package=units-opengl.source.zip[uoglsrc.zip],OpenGL interface units sources
 # Source-2 2
-package=units-gtk1.source.zip[ugtksrc.zip],GTK1 interface units sources
+package=units-gtk1.source.zip[ugtk1src.zip],GTK1 interface units sources
 # Source-2 3
 package=units-odbc.source.zip[uodbcsrc.zip],ODBC interface units sources
 # Source-2 4
@@ -723,7 +729,7 @@ package=units-os2units.source.zip[uos2src.zip],Units interfacing libraries deliv
 #package=units-clkdll.source.zip[uclksrc.zip],CLKDLL interface unit (eCS 1.1+)
 # Source-2 9
 #package=units-lvm.source.zip[ulvmsrc.zip],OS/2 LVM interface unit sources
-package=units-gtk1.source.zip[ugtk1src.zip],Header to the GTK widgetset (v1)
+package=units-sdl.source.zip[usdlsrc.zip],SDL interface units sources
 # Source-2 10
 package=units-pasjpeg.source.zip[upjpsrc.zip],PasJPEG units sources
 # Source-2 11
@@ -760,6 +766,10 @@ package=fcl-js.source.zip[ufcjssrc.zip],Free Component Library (FCL)-Javascript
 package=units-ptc.source.zip[uptcsrc.zip],Free portable framebuffer library
 # Source-2 27
 package=units-x11.source.zip[ux11src.zip],X Window (X11) interface units
+# Source-2 29
+package=units-fcl-pdf.source.zip[ufcpdsrc.zip],PDF generating and TTF file info library
+# Source-2 30
+package=units-dblib.source.zip,Headers for the MS SQL Server RDBMS
 
 
 #
@@ -802,26 +812,28 @@ package=units-httpd-2.0.source.zip[uhd20src.zip],HTTPD 2.0 interface units sourc
 # Source-3 17
 package=units-httpd-2.2.source.zip[uhd22src.zip],HTTPD 2.2 interface units sources
 # Source-3 18
-package=units-oggvorbis.source.zip[uoggvsrc.zip],OGG Vorbis interface units sources
+package=units-httpd-2.4.source.zip[uhd24src.zip],HTTPD 2.4 interface units sources
 # Source-3 19
-package=units-openal.source.zip[uoalsrc.zip],OpenAL interface units sources
+package=units-oggvorbis.source.zip[uoggvsrc.zip],OGG Vorbis interface units sources
 # Source-3 20
-package=units-openssl.source.zip[uosslsrc.zip],OpenSSL interface units sources
+package=units-openal.source.zip[uoalsrc.zip],OpenAL interface units sources
 # Source-3 21
-package=units-fcl-sound.source.zip[ufsndsrc.zip],Free Component Library (FCL)-sound files sources
+package=units-openssl.source.zip[uosslsrc.zip],OpenSSL interface units sources
 # Source-3 22
-package=units-fcl-sdo.source.zip[ufcsdsrc.zip],Free Component Library (FCL)-Service Data Objects
+package=units-fcl-sound.source.zip[ufsndsrc.zip],Free Component Library (FCL)-sound files sources
 # Source-3 23
-package=units-fcl-stl.source.zip[ufcstsrc.zip],Free Component Library (FCL)-generic container library
+package=units-fcl-sdo.source.zip[ufcsdsrc.zip],Free Component Library (FCL)-Service Data Objects
 # Source-3 24
-package=units-libtar.source.zip[ultarsrc.zip],Unit for .tar file handling
+package=units-fcl-stl.source.zip[ufcstsrc.zip],Free Component Library (FCL)-generic container library
 # Source-3 25
-package=units-rtl-console.source.zip[urtlcsrc.zip],RTL-console abstraction (keyboard, video & mouse)
+package=units-libtar.source.zip[ultarsrc.zip],Unit for .tar file handling
 # Source-3 26
-package=units-rtl-extra.source.zip[urtlesrc.zip],RTL-additional units not needed for bootstrapping
+package=units-rtl-console.source.zip[urtlcsrc.zip],RTL-console abstraction (keyboard, video & mouse)
 # Source-3 27
-package=units-rtl-objpas.source.zip[urtlosrc.zip],RTL-Object Pascal units (e.g. Delphi compatibility)
+package=units-rtl-extra.source.zip[urtlesrc.zip],RTL-additional units not needed for bootstrapping
 # Source-3 28
+package=units-rtl-objpas.source.zip[urtlosrc.zip],RTL-Object Pascal units (e.g. Delphi compatibility)
+# Source-3 29
 package=units-rtl-unicode.source.zip[urtlusrc.zip],RTL-miscellaneous Unicode support units
 
 defaultcfg=

installer/install.pas

@@ -1331,6 +1331,9 @@ end;
               messagebox('Please, choose the directory for installation first.',nil,mferror+mfokbutton)
             else
              begin
+               Data.BasePath := FExpand (Data.BasePath);
+               if Data.BasePath [Length (Data.BasePath)] = DirSep then
+                 Dec (Data.BasePath [0]);
                found:=false;
                for j:=1 to cfg.packs do
                 if data.packmask[j]>0 then
@@ -1362,9 +1365,7 @@ end;
                     end;
                   WriteLog ('Diskspace needed: ' + DotStr (DSize) + ' Kb');
 
-                  S := FExpand (Data.BasePath);
-                  if S [Length (S)] = DirSep then
-                   Dec (S [0]);
+                  S := Data.BasePath;
                   Space := DiskFree (byte (Upcase(S [1])) - 64);
                   { -1 means that the drive is invalid }
                   if Space=-1 then

packages/ami-extra/fpmake.pp

@@ -30,6 +30,8 @@ begin
     P.SourcePath.Add('src');
 
     P.OSes:=AllAmigaLikeOSes;
+    if Defaults.CPU=powerpc then
+      P.OSes:=P.OSes-[amiga];
 
     T:=P.Targets.AddUnit('cliputils.pas');
 

packages/amunits/src/coreunits/amigalib.pas

@@ -360,12 +360,9 @@ begin
 end;
 
 function DoMethodA(obj : pObject_; msg : APTR): ulong;
-var
-    o : p_Object;
 begin
     if assigned(obj) then begin
-       o := p_Object(obj);
-       DoMethodA := CallHookPkt(@o^.o_Class^.cl_Dispatcher, obj,msg);
+       DoMethodA := CallHookPkt(@THook(OCLASS(obj)^.cl_Dispatcher), obj, msg);
     end else DoMethodA := 0;
 end;
 

packages/aspell/LICENSE

@@ -464,7 +464,7 @@ convey the exclusion of warranty; and each file should have at least the
 
     You should have received a copy of the GNU Library General Public
     License along with this library; if not, write to the Free
-    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
 
 Also add information on how to contact you by electronic and paper mail.
 

packages/bfd/src/bfd.pas

@@ -52,7 +52,7 @@ GNU General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  *)
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.  *)
 
 (* bfd.h -- The only header file required by users of the bfd library
 

packages/bzip2/src/bzip2.pas

@@ -417,7 +417,7 @@ begin
             end;
           while es>0 do
             begin
-              tt^[t]:=n;
+              tt^[t]:=ntole(cardinal(n));
               dec(es);
               inc(t);
             end;
@@ -462,7 +462,7 @@ begin
                 move_mtf_block;
             end;
           inc(cftab[seq_to_unseq[n]]);
-          tt^[t]:=cardinal(seq_to_unseq[n]);
+          tt^[t]:=ntole(cardinal(seq_to_unseq[n]));
           inc(t);
           if t>100000*blocksize then
             begin
@@ -497,9 +497,9 @@ begin
   q:=p+tt_count;
   while p<>q do
     begin
-      r:=@tt^[cftab[p^ and $ff]];
-      inc(cftab[p^ and $ff]);
-      r^:=r^ or a;
+      r:=@tt^[cftab[ntole(p^) and $ff]];
+      inc(cftab[ntole(p^) and $ff]);
+      r^:=r^ or ntole(a);
       inc(a,256);
       inc(p);
     end;
@@ -567,7 +567,7 @@ procedure Tbzip2_decode_stream.new_block;
 
 begin
   if decode_block then
-    nextrle:=@tt^[tt^[block_origin] shr 8]
+    nextrle:=@tt^[ntole(tt^[block_origin]) shr 8]
   else
     begin
       error(streaderror,bzip2_endoffile);
@@ -582,7 +582,7 @@ procedure Tbzip2_decode_stream.consume_rle;inline;
 
 begin
 {  Pcardinal(nextrle)^:=Pcardinal(nextrle)^ shr 8;}
-  nextrle:=@tt^[Pcardinal(nextrle)^ shr 8];
+  nextrle:=@tt^[ntole(Pcardinal(nextrle)^) shr 8];
   dec(decode_available);
   if decode_available=0 then
     new_block;
@@ -660,7 +660,7 @@ begin
           error(streaderror,bzip2_endoffile);
           nextrle:=nil;
         end;
-      nextrle:=@tt^[tt^[block_origin] shr 8];
+      nextrle:=@tt^[ntole(tt^[block_origin]) shr 8];
     end;
   rle_read(bufptr,count);
 end;

packages/bzip2/src/bzip2stream.pp

@@ -426,7 +426,7 @@ begin
             error(SDecodingError,bzip2_data_error);
           while es>0 do
             begin
-              tt^[t]:=n;
+              tt^[t]:=ntole(cardinal(n));
               dec(es);
               inc(t);
             end;
@@ -471,7 +471,7 @@ begin
                 move_mtf_block;
             end;
           inc(cftab[seq_to_unseq[n]]);
-          tt^[t]:=cardinal(seq_to_unseq[n]);
+          tt^[t]:=ntole(cardinal(seq_to_unseq[n]));
           inc(t);
           if t>100000*blocksize then
             error(SDecodingError,bzip2_data_error);
@@ -503,9 +503,9 @@ begin
   q:=p+tt_count;
   while p<>q do
     begin
-      r:=@tt^[cftab[p^ and $ff]];
-      inc(cftab[p^ and $ff]);
-      r^:=r^ or a;
+      r:=@tt^[cftab[ntole(p^) and $ff]];
+      inc(cftab[ntole(p^) and $ff]);
+      r^:=r^ or ntole(a);
       inc(a,256);
       inc(p);
     end;
@@ -563,7 +563,7 @@ Function TDecompressBzip2Stream.new_block : Boolean;
 begin
   Result:=decode_block;
   If result then
-    nextrle:=@tt^[tt^[block_origin] shr 8]
+    nextrle:=@tt^[ntole(tt^[block_origin]) shr 8]
   else
     nextrle:=nil;
 end;
@@ -575,7 +575,7 @@ Function TDecompressBzip2Stream.consume_rle : Boolean;inline;
 
 begin
 {  Pcardinal(nextrle)^:=Pcardinal(nextrle)^ shr 8;}
-  nextrle:=@tt^[Pcardinal(nextrle)^ shr 8];
+  nextrle:=@tt^[ntole(Pcardinal(nextrle)^) shr 8];
   dec(decode_available);
   if decode_available=0 then
     Result:=new_block
@@ -652,7 +652,7 @@ begin
         nextrle:=nil;
         error(SDecodingError,bzip2_endoffile);
         end;
-      nextrle:=@tt^[tt^[block_origin] shr 8];
+      nextrle:=@tt^[ntole(tt^[block_origin]) shr 8];
     end;
   Result:=rle_read(bufptr,count);
 end;

packages/chm/src/chmfilewriter.pas

@@ -717,8 +717,8 @@ begin
 end;
 
 const
-   protocols   : array[0..3] of string = ('HTTP:','FTP:','MS-ITS:', 'MAILTO:');
-   protocollen : array[0..3] of integer= ( 5 ,4 ,7, 7);
+   protocols   : array[0..4] of string = ('HTTP:','HTTPS:','FTP:','MS-ITS:', 'MAILTO:');
+   protocollen : array[0..4] of integer= ( 5 ,6, 4 ,7, 7);
 
 function TChmProject.SanitizeURL(const basepath,instring,localpath,localname:string;var outstring:String):Boolean;
 var i,j,len : integer;
@@ -813,7 +813,8 @@ end;
 function scantags(prnt:TDomNode; const localname: string; filelist:TStringlist):TDomNode;
 // Seach first matching tag in siblings
 var chld: TDomNode;
-    s   : ansistring;
+    s,
+    att : ansistring;
     i   : Integer;
 begin
   result:=nil;
@@ -831,6 +832,11 @@ begin
                   //printattributes(chld,'');
                   checkattributes(chld,'HREF',localname,filelist);
                 end;
+              if s='SCRIPT' then
+                begin
+                  //printattributes(chld,'');
+                  checkattributes(chld,'SRC',localname,filelist);
+                end;
              if s='IMG'then
                begin
                   //printattributes(chld,'');
@@ -840,19 +846,24 @@ begin
                begin
                   //printattributes(chld,'');
                   checkattributes(chld,'HREF',localname,filelist);
-                  s := findattribute(chld,'NAME');
+                  att := 'NAME';
+                  s := findattribute(chld, att);
+                  if s = '' then begin
+                     att := 'ID';
+                     s := findattribute(chld, att);
+                  end;
                   if s <> '' then
                     begin
                       i := fAnchorList.IndexOf(localname+'#'+s);
                       if i < 0 then begin
                         fAnchorList.Add(localname+'#'+s);
-                        Error(ChmNote,'New Anchor with name '+s+' found while scanning '+localname,1);
+                        Error(ChmNote,'New Anchor with '+att+' '+s+' found while scanning '+localname,1);
                       end else if fAnchorList.Objects[i] = nil then
-                        Error(chmwarning,'Duplicate anchor definitions with name '+s+' found while scanning '+localname,1)
+                        Error(chmwarning,'Duplicate anchor definitions with '+att+' '+s+' found while scanning '+localname,1)
                       else begin
                         fAnchorList.Objects[i].Free;
                         fAnchorList.Objects[i] := nil;
-                        Error(ChmNote,'Anchor with name '+s+' defined while scanning '+localname,1);
+                        Error(ChmNote,'Anchor with '+att+' '+s+' defined while scanning '+localname,1);
                       end;
                     end;
                 end;

packages/chm/src/paslzxcomp.pas

@@ -61,7 +61,7 @@ uses paslznonslide;
   
       You should have received a copy of the GNU Lesser General Public License
       along with this program; if not, write to the Free Software
-      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+      Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
    }
    type
   PPlzx_data = ^Plzx_data;

packages/dblib/src/dblib.pp

@@ -22,6 +22,7 @@
                     7.1 - MS SQL Server 2000 (*default*)
                     7.2 - MS SQL Server 2005
                     7.3 - MS SQL Server 2008
+                    7.4 - MS SQL Server 2012/2014
       tds version can be set using env.var. TDSVER or in freetds.conf or .freetds.conf
 }
 unit dblib;
@@ -59,6 +60,7 @@ const
   DBVERSION_71 = 5;
   DBVERSION_72 = 6;
   DBVERSION_73 = 7;
+  DBVERSION_74 = 8;
 
   //DBTDS_xxx are returned by DBTDS()
   DBTDS_UNKNOWN= 0;
@@ -68,6 +70,7 @@ const
   DBTDS_71     = 9;  // Microsoft SQL Server 2000
   DBTDS_72     = 10; // Microsoft SQL Server 2005
   DBTDS_73     = 11; // Microsoft SQL Server 2008
+  DBTDS_74     = 12; // Microsoft SQL Server 2012/2014
 
   //from sqlfront.h , sybdb.h for FreeTDS
   DBSETHOST=1;
@@ -102,6 +105,9 @@ const
   DBANSItoOEM  = 14;
   DBOEMtoANSI  = 15;
   DBQUOTEDIDENT= {$IFDEF freetds}35{$ELSE}18{$ENDIF};
+  // settings from here are purely FreeTDS extensions:
+  DBSETUTF16   = 1001;
+  DBSETNTLMV2  = 1002;
 
   TIMEOUT_IGNORE=-1;
   TIMEOUT_INFINITE=0;
@@ -173,7 +179,9 @@ const
 
   // Error codes:
   SYBEFCON = 20002;      // SQL Server connection failed
+  SYBEWRIT = 20006;      // Write to SQL Server failed.
   SYBESMSG = 20018;      // General SQL Server error: Check messages from the SQL Server.
+  SYBEDDNE = 20047;      // DBPROCESS is dead or not enabled.
 
 type
   PLOGINREC=Pointer;
@@ -195,6 +203,9 @@ type
   DBSMALLINT=smallint;   // 16-bit int (short)
   DBUSMALLINT=word;      // 16-bit unsigned int (unsigned short)
   DBINT=longint;         // 32-bit int (int)
+  DBUINT=longword;       // 32-bit unsigned int
+  DBBIGINT=int64;        // 64-bit integer
+  DBUBIGINT=qword;       // 64-bit unsigned
   DBFLT8=double;         // 64-bit real (double)
   DBBINARY=byte;
 
@@ -206,9 +217,9 @@ type
   PDBDATETIME=^DBDATETIME;
 
   DBDATETIMEALL=record
-    time: qword;         // time, 7 digit precision (64-bit unsigned)
-    date: longint;       // date, 0 = 1900-01-01 (32-bit int)
-    offset: smallint;    // time offset (16-bit int)
+    time: DBUBIGINT;     // time, 7 digit precision (64-bit unsigned)
+    date: DBINT;         // date, 0 = 1900-01-01 (32-bit int)
+    offset: DBSMALLINT;  // time offset (16-bit int)
     info: word;          // unsigned short time_prec:3;
                          // unsigned short _res:10;
                          // unsigned short has_time:1;
@@ -249,11 +260,27 @@ type
       minute: INT;      // 0 - 59
       second: INT;      // 0 - 59
       millisecond: INT; // 0 - 999
-      tzone: INT;       // 0 - 127 (Sybase only!)
+      tzone: INT;       // -840 - 840
     );
   end;
   PDBDATEREC=^DBDATEREC;
 
+  DBDATEREC2 = record
+    year: DBINT;        // 1753 - 9999
+    quarter: DBINT;     // 1 - 4
+    month: DBINT;       // 1 - 12
+    day: DBINT;         // 1 - 31
+    dayofyear: DBINT;   // 1 - 366
+    week: DBINT;        // 1 - 54 (for leap years)
+    weekday: DBINT;     // 1 - 7 (Mon. - Sun.)
+    hour: DBINT;        // 0 - 23
+    minute: DBINT;      // 0 - 59
+    second: DBINT;      // 0 - 59
+    nanosecond: DBINT;  // 0 - 999999999
+    tzone: DBINT;       // 0 - 127  (Sybase only)
+  end;
+  PDBDATEREC2=^DBDATEREC2;
+
   DBMONEY=record
     mnyhigh: DBINT;
     mnylow: ULONG;
@@ -336,6 +363,7 @@ var
   function dbiscount(dbproc:PDBPROCESS):BOOL; cdecl; external DBLIBDLL;
   function dbcancel(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
   function dbcanquery(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
+  function dbdead(dbproc:PDBPROCESS):DBBOOL; cdecl; external DBLIBDLL;
   function dbhasretstat(dbproc:PDBPROCESS):DBBOOL; cdecl; external DBLIBDLL;
   function dbretstatus(dbproc:PDBPROCESS):DBINT; cdecl; external DBLIBDLL;
   procedure dbfreelogin(login:PLOGINREC); cdecl; external DBLIBDLL {$IFDEF freetds}name 'dbloginfree'{$ENDIF};
@@ -385,6 +413,7 @@ var
   dbiscount: function(dbproc:PDBPROCESS):BOOL; cdecl;
   dbcancel: function(dbproc:PDBPROCESS):RETCODE; cdecl;
   dbcanquery: function(dbproc:PDBPROCESS):RETCODE; cdecl;
+  dbdead: function(dbproc:PDBPROCESS):DBBOOL; cdecl;
   dbhasretstat: function(dbproc:PDBPROCESS):DBBOOL; cdecl;
   dbretstatus: function(dbproc:PDBPROCESS):DBINT; cdecl;
   dbexit: procedure(); cdecl;
@@ -396,6 +425,7 @@ var
   {$ENDIF}
   {$IFDEF freetds}
   tdsdbopen: function(login:PLOGINREC; servername:PAnsiChar; msdblib:INT):PDBPROCESS; cdecl;
+  dbanydatecrack: function(dbproc:PDBPROCESS; di: PDBDATEREC2; typ: INT; data: pointer):RETCODE; cdecl;
   dbtablecolinfo: function(dbproc:PDBPROCESS; column:DBINT; dbcol:PDBCOL):RETCODE; cdecl;
   dbtds: function(dbproc:PDBPROCESS):INT; cdecl;
   dbsetlversion: function(login:PLOGINREC; version:BYTE):RETCODE; cdecl;
@@ -484,6 +514,7 @@ begin
    pointer(dbiscount) := GetProcedureAddress(DBLibLibraryHandle,'dbiscount');
    pointer(dbcancel) := GetProcedureAddress(DBLibLibraryHandle,'dbcancel');
    pointer(dbcanquery) := GetProcedureAddress(DBLibLibraryHandle,'dbcanquery');
+   pointer(dbdead) := GetProcedureAddress(DBLibLibraryHandle,'dbdead');
    pointer(dbhasretstat) := GetProcedureAddress(DBLibLibraryHandle,'dbhasretstat');
    pointer(dbretstatus) := GetProcedureAddress(DBLibLibraryHandle,'dbretstatus');
    pointer(dbexit) := GetProcedureAddress(DBLibLibraryHandle,'dbexit');

packages/fcl-base/examples/README.txt

@@ -75,3 +75,4 @@ daemon.pp    Test for daemonapp (MVC)
 testtimer.pp Test for TFPTimer (MVC)
 testini.pp   Test/Demo for inifiles, ReadSectionValues.
 contit.pp    Test/Demo for iterators in contnr.pp
+csvbom.pp    Test/Demo for BOM detection in CSV document. (needs databom.txt)

packages/fcl-base/examples/csvbom.pp

@@ -0,0 +1,53 @@
+program csvbom;
+
+{$APPTYPE Console}
+{$mode objfpc}{$H+}
+
+uses
+  sysutils, classes, dateutils, csvreadwrite;
+
+type
+  TDataRec = record
+    FDate: TDate;
+    FNumber: Integer;
+    FText: String;
+  end;
+
+const
+  FILENAME = 'databom.txt';
+
+var
+  parser: TCSVParser;
+  stream: TFileStream;
+  data: array of TDataRec;
+  s: String;
+  i: Integer;
+begin
+  parser := TCSVParser.Create;
+  try
+    parser.Delimiter := ',';
+    parser.DetectBOM := true;     // uncomment for running with patched version
+    stream := TFileStream.Create(FILENAME, fmOpenRead);
+    parser.SetSource(stream);
+    SetLength(data, 0);
+    while parser.ParseNextCell do begin
+      if parser.CurrentRow > High(data) then
+        SetLength(data, parser.CurrentRow + 1);
+      s := parser.CurrentCellText;
+      case parser.CurrentCol of
+        0: data[High(data)].FDate := ScanDateTime('yyyy-mm-dd', s);
+        1: data[High(data)].FNumber := StrToInt(s);
+        2: data[High(data)].FText := s;
+      end;
+    end;
+
+    for i:=0 to High(data) do
+      WriteLn(DateToStr(data[i].FDate), '; ', data[i].FNumber, '; ', data[i].FText);
+    Writeln('Press enter to quit program');
+    Readln;
+  finally
+    stream.Free;
+    parser.Free;
+  end;
+end.
+

packages/fcl-base/examples/databom.txt

@@ -0,0 +1,2 @@
+2016-01-01,100,ABC
+2016-01-02,110,DEF

packages/fcl-base/examples/testapp.pp

@@ -6,9 +6,9 @@ program testapp;
 uses custapp,classes;
 
 Const
-  ShortOpts = 'abc:d:012';
-  Longopts : Array[1..6] of String = (
-    'add:','append','delete:','verbose','create:','file:');
+  ShortOpts = 'iabc:d:012';
+  Longopts : Array[1..7] of String = (
+    'insensitive','add:','append','delete:','verbose','create:','file:');
 
 Type
   TTestApp = Class(TCustomApplication)
@@ -23,6 +23,7 @@ Var
   Opts,FN,Args : TStrings;
 
 begin
+  CaseSensitiveOptions:=not HasOption('i','insensitive'); 
   Writeln('Exe name            : ',ExeName);
   Writeln('Help file           : ',HelpFile);
   Writeln('Terminated          : ',Terminated);
@@ -60,6 +61,7 @@ begin
     Writeln('Option append found: ',HasOption('append'));
     Writeln('Option a or append found: ',HasOption('a','append'));
     Writeln('-----------------------');
+    Opts.Clear;
     GetEnvironmentList(Opts,True);
     Writeln('Found ',Opts.Count,' environment variables');
     For I:=0 to Opts.Count-1 do

packages/fcl-base/fpmake.pp

@@ -124,7 +124,7 @@ begin
       end;
     T:=P.Targets.addUnit('advancedipc.pp');
       T.ResourceStrings:=true;
-    T:=P.Targets.addUnit('advancedsingleinstance.pp');
+    T:=P.Targets.addUnit('advancedsingleinstance.pas');
       T.ResourceStrings:=true;	  
     // Additional sources
     P.Sources.AddSrcFiles('src/win/fclel.*', P.Directory);

packages/fcl-base/src/csvdocument.pp

@@ -32,7 +32,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 unit csvdocument;

packages/fcl-base/src/csvreadwrite.pp

@@ -32,7 +32,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 unit csvreadwrite;
@@ -92,12 +92,16 @@ Type
 
   { TCSVParser }
 
+  TCSVByteOrderMark = (bomNone, bomUTF8, bomUTF16LE, bomUTF16BE);
+
   TCSVParser = class(TCSVHandler)
   private
     FFreeStream: Boolean;
     // fields
     FSourceStream: TStream;
     FStrStreamWrapper: TStringStream;
+    FBOM: TCSVByteOrderMark;
+    FDetectBOM: Boolean;
     // parser state
     EndOfFile: Boolean;
     EndOfLine: Boolean;
@@ -140,6 +144,10 @@ Type
     property MaxColCount: Integer read FMaxColCount;
     // Does the parser own the stream ? If true, a previous stream is freed when set or when parser is destroyed.
     Property FreeStream : Boolean Read FFreeStream Write FFreeStream;
+    // Return BOM found in file
+    property BOM: TCSVByteOrderMark read FBOM;
+    // Detect whether a BOM marker is present. If set to True, then BOM can be used to see what BOM marker there was.
+    property DetectBOM: Boolean read FDetectBOM write FDetectBOM default false;
   end;
 
   // Sequential output to CSV stream
@@ -441,9 +449,32 @@ begin
 end;
 
 procedure TCSVParser.ResetParser;
+var
+  b: packed array[0..2] of byte;
+  n: Integer;
 begin
   ClearOutput;
   FSourceStream.Seek(0, soFromBeginning);
+  if FDetectBOM then
+  begin
+    FSourceStream.ReadBuffer(b[0], 3);
+    if (b[0] = $EF) and (b[1] = $BB) and (b[2] = $BF) then begin
+      FBOM := bomUTF8;
+      n := 3;
+    end else
+    if (b[0] = $FE) and (b[1] = $FF) then begin
+      FBOM := bomUTF16BE;
+      n := 2;
+    end else
+    if (b[0] = $FF) and (b[1] = $FE) then begin
+      FBOM := bomUTF16LE;
+      n := 2;
+    end else begin
+      FBOM := bomNone;
+      n := 0;
+    end;
+    FSourceStream.Seek(n, soFromBeginning);
+  end;
   EndOfFile := False;
   NextChar;
 end;

packages/fcl-base/src/custapp.pp

@@ -285,7 +285,7 @@ begin
   except
     On E : Exception do
       Log(etError,Format('Error formatting message "%s" with %d arguments: %s',[Fmt,Length(Args),E.Message]));
-  end  
+  end
 end;
 
 constructor TCustomApplication.Create(AOwner: TComponent);
@@ -362,15 +362,14 @@ end;
 
 procedure TCustomApplication.Terminate;
 begin
-  Terminate(0);
+  Terminate(ExitCode);
 end;
 
 procedure TCustomApplication.Terminate(AExitCode : Integer) ;
 
 begin
   FTerminated:=True;
-  If (AExitCode<>0) then
-    ExitCode:=AExitCode;
+  ExitCode:=AExitCode;
 end;
 
 function TCustomApplication.GetOptionAtIndex(AIndex : Integer; IsLong: Boolean): String;
@@ -597,7 +596,7 @@ begin
     If (Length(O)=0) or (O[1]<>FOptionChar) then
       begin
       If Assigned(NonOpts) then
-        NonOpts.Add(O)
+        NonOpts.Add(O);
       end
     else
       begin
@@ -623,7 +622,7 @@ begin
           If FindLongopt(O) then
             begin
             If HaveArg then
-              AddToResult(Format(SErrNoOptionAllowed,[I,O]))
+              AddToResult(Format(SErrNoOptionAllowed,[I,O]));
             end
           else
             begin // Required argument
@@ -643,23 +642,21 @@ begin
           begin
           HaveArg:=(I<ParamCount) and (Length(ParamStr(I+1))>0) and (ParamStr(I+1)[1]<>FOptionChar);
           UsedArg:=False;
-          If HaveArg then
-            OV:=Paramstr(I+1);
           If Not CaseSensitiveOptions then
             O:=LowerCase(O);
           L:=Length(O);
           J:=2;
           While ((Result='') or AllErrors) and (J<=L) do
             begin
-            P:=Pos(O[J],ShortOptions);
+            P:=Pos(O[J],SO);
             If (P=0) or (O[j]=':') then
               AddToResult(Format(SErrInvalidOption,[I,O[J]]))
             else
               begin
-              If (P<Length(ShortOptions)) and (Shortoptions[P+1]=':') then
+              If (P<Length(SO)) and (SO[P+1]=':') then
                 begin
                 // Required argument
-                If ((P+1)=Length(ShortOptions)) or (Shortoptions[P+2]<>':') Then
+                If ((P+1)=Length(SO)) or (SO[P+2]<>':') Then
                   If (J<L) or not haveArg then // Must be last in multi-opt !!
                     AddToResult(Format(SErrOptionNeeded,[I,O[J]]));
                 O:=O[j]; // O is added to arguments.
@@ -668,10 +665,11 @@ begin
               end;
             Inc(J);
             end;
-          If HaveArg and UsedArg then
+          HaveArg:=HaveArg and UsedArg;
+          If HaveArg then
             begin
             Inc(I); // Skip argument.
-            O:=O[Length(O)]; // O is added to arguments !
+            OV:=Paramstr(I);
             end;
           end;
         If HaveArg and ((Result='') or AllErrors) then

packages/fcl-base/src/fptimer.pp

@@ -334,6 +334,7 @@ Var
   Diff: Extended;
    
 begin
+  Result:=False;
     { Use Counter*fInterval to avoid numerical errors resulting from adding
       small values (AInterval/cMilliSecs) to a large real number (TDateTime),
       even when using Extended precision }

packages/fcl-base/src/inifiles.pp

@@ -165,7 +165,7 @@ type
     procedure WriteString(const Section, Ident, Value: String); virtual; abstract;
     function ReadInteger(const Section, Ident: string; Default: Longint): Longint; virtual;
     procedure WriteInteger(const Section, Ident: string; Value: Longint); virtual;
-    function ReadInt64(const Section, Ident: string; Default: Int64): Longint; virtual;
+    function ReadInt64(const Section, Ident: string; Default: Int64): Int64; virtual;
     procedure WriteInt64(const Section, Ident: string; Value: Int64); virtual;
     function ReadBool(const Section, Ident: string; Default: Boolean): Boolean; virtual;
     procedure WriteBool(const Section, Ident: string; Value: Boolean); virtual;
@@ -220,7 +220,7 @@ type
     procedure ReadSection(const Section: string; Strings: TStrings); override;
     procedure ReadSectionRaw(const Section: string; Strings: TStrings);
     procedure ReadSections(Strings: TStrings); override;
-    procedure ReadSectionValues(const Section: string; Strings: TStrings; AOptions : TSectionValuesOptions = []); overload; override;
+    procedure ReadSectionValues(const Section: string; Strings: TStrings; AOptions : TSectionValuesOptions = [svoIncludeInvalid]); overload; override;
     procedure EraseSection(const Section: string); override;
     procedure DeleteKey(const Section, Ident: String); override;
     procedure UpdateFile; override;
@@ -337,7 +337,10 @@ begin
   if not FValueHashValid then
     UpdateValueHash;
 
-  I := FValueHash.FindIndexOf(S);
+  if CaseSensitive then
+    I := FValueHash.FindIndexOf(S)
+  else
+    I := FValueHash.FindIndexOf(AnsiUpperCase(S));
   if I >= 0 then
     Result := Integer(FValueHash[I])-1
   else
@@ -351,7 +354,10 @@ begin
   if not FNameHashValid then
     UpdateNameHash;
 
-  I := FNameHash.FindIndexOf(Name);
+  if CaseSensitive then
+    I := FNameHash.FindIndexOf(Name)
+  else
+    I := FNameHash.FindIndexOf(AnsiUpperCase(Name));
   if I >= 0 then
     Result := Integer(FNameHash[I])-1
   else
@@ -374,7 +380,10 @@ begin
   else
     FValueHash.Clear;
   for I := 0 to Count - 1 do
-    FValueHash.Add(Strings[I], Pointer(I+1));
+    if CaseSensitive then
+      FValueHash.Add(Strings[I], Pointer(I+1))
+    else
+      FValueHash.Add(AnsiUpperCase(Strings[I]), Pointer(I+1));
   FValueHashValid := True;
 end;
 
@@ -387,7 +396,10 @@ begin
   else
     FNameHash.Clear;
   for I := 0 to Count - 1 do
-    FNameHash.Add(Names[I], Pointer(I+1));
+    if CaseSensitive then
+      FNameHash.Add(Names[I], Pointer(I+1))
+    else
+      FNameHash.Add(AnsiUpperCase(Names[I]), Pointer(I+1));
   FNameHashValid := True;
 end;
 
@@ -608,7 +620,7 @@ begin
 end;
 
 function TCustomIniFile.ReadInt64(const Section, Ident: string; Default: Int64
-  ): Longint;
+  ): Int64;
 begin
   Result := StrToInt64Def(ReadString(Section, Ident, ''), Default);
 end;
@@ -820,7 +832,7 @@ end;
 procedure TCustomIniFile.ReadSectionValues(const Section: string;
   Strings: TStrings);
 begin
-  ReadSectionValues(Section,Strings,[]);
+  ReadSectionValues(Section,Strings,[svoIncludeInvalid]);
 end;
 
 { TIniFile }
@@ -1101,7 +1113,7 @@ begin
   end;
 end;
 
-procedure TIniFile.ReadSectionValues(const Section: string; Strings: TStrings; AOptions : TSectionValuesOptions = []);
+procedure TIniFile.ReadSectionValues(const Section: string; Strings: TStrings; AOptions : TSectionValuesOptions = [svoIncludeInvalid]);
 var
   oSection: TIniFileSection;
   s: string;

packages/fcl-base/src/streamex.pp

@@ -86,13 +86,14 @@ type
    { TTextReader }
 
    TTextReader = class(TObject)
+   Protected
+     function IsEof: Boolean; virtual; abstract;
    public
      constructor Create; virtual;
      procedure Reset; virtual; abstract;
      procedure Close; virtual; abstract;
-     function IsEof: Boolean; virtual; abstract;
      procedure ReadLine(out AString: string); virtual; abstract; overload;
-     function ReadLine: string; virtual; abstract; overload;
+     function ReadLine: string; overload;
      property Eof: Boolean read IsEof;
    end;
 
@@ -102,10 +103,13 @@ type
    private
      FBufferRead: Integer;
      FBufferPosition: Integer;
+     FClosed,
      FOwnsStream: Boolean;
      FStream: TStream;
      FBuffer: array of Byte;
      procedure FillBuffer;
+   Protected  
+     function IsEof: Boolean; override;
    public
      constructor Create(AStream: TStream; ABufferSize: Integer;
        AOwnsStream: Boolean); virtual;
@@ -113,9 +117,7 @@ type
      destructor Destroy; override;
      procedure Reset; override;
      procedure Close; override;
-     function IsEof: Boolean; override;
      procedure ReadLine(out AString: string); override; overload;
-     function ReadLine: string; override; overload;
      property BaseStream: TStream read FStream;
      property OwnsStream: Boolean read FOwnsStream write FOwnsStream;
    end;
@@ -125,15 +127,15 @@ type
    TStringReader = class(TTextReader)
    private
      FReader: TTextReader;
+   Protected  
+     function IsEof: Boolean; override;
    public
      constructor Create(const AString: string; ABufferSize: Integer); virtual;
      constructor Create(const AString: string); virtual;
      destructor Destroy; override;
      procedure Reset; override;
      procedure Close; override;
-     function IsEof: Boolean; override;
      procedure ReadLine(out AString: string); override; overload;
-     function ReadLine: string; override; overload;
    end;
 
    { TFileReader }
@@ -141,6 +143,8 @@ type
    TFileReader = class(TTextReader)
    private
      FReader: TTextReader;
+   Protected
+     function IsEof: Boolean; override;
    public
      constructor Create(const AFileName: TFileName; AMode: Word;
        ARights: Cardinal; ABufferSize: Integer); virtual;
@@ -151,9 +155,7 @@ type
      destructor Destroy; override;
      procedure Reset; override;
      procedure Close; override;
-     function IsEof: Boolean; override;
      procedure ReadLine(out AString: string); override; overload;
-     function ReadLine: string; override; overload;
    end;
 
   { allows you to represent just a small window of a bigger stream as a substream. 
@@ -331,6 +333,12 @@ begin
   inherited Create;
 end;
 
+function TTextReader.ReadLine: string;
+
+begin
+  ReadLine(Result);
+end;
+
 { TStreamReader }
 
 constructor TStreamReader.Create(AStream: TStream; ABufferSize: Integer;
@@ -341,6 +349,7 @@ begin
     raise EArgumentException.CreateFmt(SParamIsNil, ['AStream']);
   FStream := AStream;
   FOwnsStream := AOwnsStream;
+  FClosed:=False;
   if ABufferSize >= MIN_BUFFER_SIZE then
     SetLength(FBuffer, ABufferSize)
   else
@@ -360,9 +369,17 @@ end;
 
 procedure TStreamReader.FillBuffer;
 begin
-  FBufferRead := FStream.Read(FBuffer[0], Pred(Length(FBuffer)));
-  FBuffer[FBufferRead] := 0;
-  FBufferPosition := 0;
+  if FClosed then 
+    begin
+    FBufferRead:=0;
+    FBufferPosition:=0;
+    end
+  else  
+    begin
+    FBufferRead := FStream.Read(FBuffer[0], Pred(Length(FBuffer)));
+    FBuffer[FBufferRead] := 0;
+    FBufferPosition := 0;
+    end;
 end;
 
 procedure TStreamReader.Reset;
@@ -376,15 +393,13 @@ end;
 procedure TStreamReader.Close;
 begin
   if FOwnsStream then
-  begin
-    FStream.Free;
-    FStream := nil;
-  end;
+    FreeAndNil(FStream);
+  FClosed:=True;
 end;
 
 function TStreamReader.IsEof: Boolean;
 begin
-  if not Assigned(FStream) then
+  if FClosed or not Assigned(FStream) then
     Exit(True);
   Result := FBufferPosition >= FBufferRead;
   if Result then
@@ -401,6 +416,7 @@ var
 begin
   VPosition := FBufferPosition;
   SetLength(AString, 0);
+  if FClosed then exit;
   repeat
     VPByte := @FBuffer[FBufferPosition];
     while (FBufferPosition < FBufferRead) and not (VPByte^ in [10, 13]) do
@@ -441,10 +457,6 @@ begin
   end;
 end;
 
-function TStreamReader.ReadLine: string;
-begin
-  ReadLine(Result);
-end;
 
 { TStringReader }
 
@@ -485,11 +497,6 @@ begin
   FReader.ReadLine(AString);
 end;
 
-function TStringReader.ReadLine: string;
-begin
-  ReadLine(Result);
-end;
-
 { TFileReader }
 
 constructor TFileReader.Create(const AFileName: TFileName; AMode: Word;
@@ -542,11 +549,6 @@ begin
   FReader.ReadLine(AString);
 end;
 
-function TFileReader.ReadLine: string;
-begin
-  ReadLine(Result);
-end;
-
 { TStreamHelper }
 
 function TStreamHelper.readwordLE:word;

packages/fcl-base/src/syncobjs.pp

@@ -28,6 +28,10 @@ const
   INFINITE = Cardinal(-1);
 
 type
+   ESyncObjectException = Class(Exception);
+   ELockException = Class(ESyncObjectException);
+   ELockRecursionException = Class(ESyncObjectException);
+   
    TWaitResult = (wrSignaled, wrTimeout, wrAbandoned, wrError);
 
    TSynchroObject = class(TObject)
@@ -79,6 +83,9 @@ type
 
 implementation
 
+Resourcestring
+  SErrEventCreateFailed = 'Failed to create OS basic event with name "%s"'; 
+
 { ---------------------------------------------------------------------
     Real syncobjs implementation
   ---------------------------------------------------------------------}
@@ -150,6 +157,8 @@ constructor TEventObject.Create(EventAttributes : PSecurityAttributes;
 
 begin
   FHandle := BasicEventCreate(EventAttributes, AManualReset, InitialState, Name);
+  if (FHandle=Nil) then
+    Raise ESyncObjectException.CreateFmt(SErrEventCreateFailed,[Name]);
   FManualReset:=AManualReset;
 end;
 

packages/fcl-base/tests/fclbase-unittests.lpi

@@ -1,4 +1,4 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
     <Version Value="9"/>
@@ -6,7 +6,6 @@
       <Flags>
         <MainUnitHasCreateFormStatements Value="False"/>
         <MainUnitHasTitleStatement Value="False"/>
-        <UseDefaultCompilerOptions Value="True"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
       <MainUnit Value="0"/>
@@ -31,35 +30,35 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+        <CommandLineParams Value="--suite=TTestParserVariables.TestVariable31"/>
       </local>
     </RunParams>
-    <Units Count="2">
+    <Units Count="3">
       <Unit0>
         <Filename Value="fclbase-unittests.pp"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="fclbase_unittests"/>
       </Unit0>
       <Unit1>
         <Filename Value="tchashlist.pp"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="tchashlist"/>
       </Unit1>
+      <Unit2>
+        <Filename Value="testexprpars.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
     </Units>
   </ProjectOptions>
   <CompilerOptions>
     <Version Value="11"/>
     <Target>
-      <Filename Value="project1"/>
+      <Filename Value="fclbase-unittests"/>
     </Target>
     <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../src"/>
       <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
-    <Other>
-      <CompilerMessages>
-        <MsgFileName Value=""/>
-      </CompilerMessages>
-      <CompilerPath Value="$(CompPath)"/>
-    </Other>
   </CompilerOptions>
   <Debugging>
     <Exceptions Count="3">

packages/fcl-base/tests/fclbase-unittests.pp

@@ -10,6 +10,8 @@ var
   Application: TTestRunner;
 
 begin
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
   Application := TTestRunner.Create(nil);
   Application.Initialize;
   Application.Title := 'FCL-Base unittests';

packages/fcl-base/tests/testexprpars.pp

@@ -20,7 +20,7 @@ unit testexprpars;
 interface
 
 uses
-  Classes, SysUtils, fpcunit, testutils, testregistry,fpexprpars;
+  Classes, SysUtils, fpcunit, testutils, testregistry, math, fpexprpars;
 
 type
 
@@ -31,6 +31,7 @@ type
     FP : TFPExpressionScanner;
     FInvalidString : String;
     procedure DoInvalidNumber(AString: String);
+    procedure TestIdentifier(const ASource, ATokenName: string);
     procedure TestInvalidNumber;
   protected
     procedure SetUp; override; 
@@ -46,6 +47,7 @@ type
     Procedure TestInvalidCharacter;
     Procedure TestUnterminatedString;
     Procedure TestQuotesInString;
+    Procedure TestIdentifiers;
   end;
 
   { TMyFPExpressionParser }
@@ -412,6 +414,27 @@ type
     Procedure TestAsString;
   end;
 
+  { TTestPowerNode }
+
+  TTestPowerNode = Class(TTestBaseParser)
+  Private
+    FN : TFPPowerOperation;
+    FE : TFPExpressionParser;
+  Protected
+    Procedure Setup; override;
+    Procedure TearDown; override;
+    procedure Calc(AExpr: String; Expected: Double = NaN);
+  Published
+    Procedure TestCreateInteger;
+    Procedure TestCreateFloat;
+    Procedure TestCreateDateTime;
+    Procedure TestCreateString;
+    Procedure TestCreateBoolean;
+    Procedure TestDestroy;
+    Procedure TestAsString;
+    Procedure TestCalc;
+  end;
+
   { TTestDivideNode }
 
   TTestDivideNode = Class(TTestBaseParser)
@@ -701,6 +724,12 @@ type
   TTestParserVariables = Class(TTestExpressionParser)
   private
     FAsWrongType : TResultType;
+    FEventName: String;
+    FBoolValue : Boolean;
+    FTest33 : TFPExprIdentifierDef;
+    procedure DoGetBooleanVar(var Res: TFPExpressionResult; ConstRef AName: ShortString);
+    procedure DoGetBooleanVarWrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
+    procedure DoTestVariable33;
     procedure TestAccess(Skip: TResultType);
   Protected
     procedure AddVariabletwice;
@@ -741,6 +770,10 @@ type
     procedure TestVariable28;
     procedure TestVariable29;
     procedure TestVariable30;
+    procedure TestVariable31;
+    procedure TestVariable32;
+    procedure TestVariable33;
+    procedure TestVariable34;
   end;
 
   { TTestParserFunctions }
@@ -782,6 +815,45 @@ type
     procedure TestFunction29;
   end;
 
+  { TAggregateNode }
+
+  TAggregateNode = Class(TFPExprNode)
+  Public
+    InitCount : Integer;
+    UpdateCount : Integer;
+    Class Function IsAggregate: Boolean; override;
+    Function NodeType: TResultType; override;
+    Procedure InitAggregate; override;
+    Procedure UpdateAggregate; override;
+    procedure GetNodeValue(var Result: TFPExpressionResult); override;
+  end;
+
+  { TTestParserAggregate }
+
+  TTestParserAggregate = Class(TTestExpressionParser)
+  private
+    FVarValue : Integer;
+    FLeft : TAggregateNode;
+    FRight : TAggregateNode;
+    FFunction : TFPExprIdentifierDef;
+    FFunction2 : TFPExprIdentifierDef;
+  Protected
+    Procedure Setup; override;
+    Procedure TearDown; override;
+  public
+    procedure GetVar(var Result: TFPExpressionResult; ConstRef AName: ShortString);
+  Published
+    Procedure TestIsAggregate;
+    Procedure TestHasAggregate;
+    Procedure TestBinaryAggregate;
+    Procedure TestUnaryAggregate;
+    Procedure TestCountAggregate;
+    Procedure TestSumAggregate;
+    Procedure TestSumAggregate2;
+    Procedure TestAvgAggregate;
+    Procedure TestAvgAggregate2;
+    Procedure TestAvgAggregate3;
+  end;
   { TTestBuiltinsManager }
 
   TTestBuiltinsManager = Class(TTestExpressionParser)
@@ -804,8 +876,11 @@ type
 
   TTestBuiltins = Class(TTestExpressionParser)
   private
+    FValue : Integer;
     FM : TExprBuiltInManager;
     FExpr : String;
+    procedure DoAverage(Var Result : TFPExpressionResult; ConstRef AName : ShortString);
+    procedure DoSeries(var Result: TFPExpressionResult; ConstRef AName: ShortString);
   Protected
     procedure Setup; override;
     procedure Teardown; override;
@@ -817,6 +892,8 @@ type
     procedure AssertExpression(Const AExpression : String; Const AResult : TExprFloat);
     procedure AssertExpression(Const AExpression : String; Const AResult : Boolean);
     procedure AssertDateTimeExpression(Const AExpression : String; Const AResult : TDateTime);
+    procedure AssertAggregateExpression(Const AExpression : String; AResult : Int64; AUpdateCount : integer);
+    procedure AssertAggregateExpression(Const AExpression : String; AResult : TExprFloat; AUpdateCount : integer);
   Published
     procedure TestRegister;
     Procedure TestVariablepi;
@@ -883,12 +960,337 @@ type
     Procedure TestFunctionstrtotimedef;
     Procedure TestFunctionstrtodatetime;
     Procedure TestFunctionstrtodatetimedef;
+    Procedure TestFunctionAggregateSum;
+    Procedure TestFunctionAggregateCount;
+    Procedure TestFunctionAggregateAvg;
+    Procedure TestFunctionAggregateMin;
+    Procedure TestFunctionAggregateMax;
   end;
 
 implementation
 
 uses typinfo;
 
+{ TTestParserAggregate }
+
+procedure TTestParserAggregate.Setup;
+begin
+  inherited Setup;
+  FVarValue:=0;
+  FFunction:=TFPExprIdentifierDef.Create(Nil);
+  FFunction.Name:='Count';
+  FFunction2:=TFPExprIdentifierDef.Create(Nil);
+  FFunction2.Name:='MyVar';
+  FFunction2.ResultType:=rtInteger;
+  FFunction2.IdentifierType:=itVariable;
+  FFunction2.OnGetVariableValue:=@GetVar;
+  FLeft:=TAggregateNode.Create;
+  FRight:=TAggregateNode.Create;
+end;
+
+procedure TTestParserAggregate.TearDown;
+begin
+  FreeAndNil(FFunction);
+  FreeAndNil(FLeft);
+  FreeAndNil(FRight);
+  inherited TearDown;
+end;
+
+procedure TTestParserAggregate.GetVar(var Result: TFPExpressionResult; ConstRef
+  AName: ShortString);
+begin
+  Result.ResultType:=FFunction2.ResultType;
+  Case Result.ResultType of
+    rtInteger : Result.ResInteger:=FVarValue;
+    rtFloat : Result.ResFloat:=FVarValue / 2;
+  end;
+end;
+
+procedure TTestParserAggregate.TestIsAggregate;
+begin
+  AssertEquals('ExprNode',False,TFPExprNode.IsAggregate);
+  AssertEquals('TAggregateExpr',True,TAggregateExpr.IsAggregate);
+  AssertEquals('TAggregateExpr',False,TFPBinaryOperation.IsAggregate);
+end;
+
+procedure TTestParserAggregate.TestHasAggregate;
+
+Var
+  N :  TFPExprNode;
+
+begin
+  N:=TFPExprNode.Create;
+  try
+    AssertEquals('ExprNode',False,N.HasAggregate);
+  finally
+    N.Free;
+  end;
+  N:=TAggregateExpr.Create;
+  try
+    AssertEquals('ExprNode',True,N.HasAggregate);
+  finally
+    N.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestBinaryAggregate;
+
+Var
+  B :  TFPBinaryOperation;
+
+begin
+  B:=TFPBinaryOperation.Create(Fleft,TFPConstExpression.CreateInteger(1));
+  try
+    FLeft:=Nil;
+    AssertEquals('Binary',True,B.HasAggregate);
+  finally
+    B.Free;
+  end;
+  B:=TFPBinaryOperation.Create(TFPConstExpression.CreateInteger(1),FRight);
+  try
+    FRight:=Nil;
+    AssertEquals('Binary',True,B.HasAggregate);
+  finally
+    B.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestUnaryAggregate;
+Var
+  B : TFPUnaryOperator;
+
+begin
+  B:=TFPUnaryOperator.Create(Fleft);
+  try
+    FLeft:=Nil;
+    AssertEquals('Unary',True,B.HasAggregate);
+  finally
+    B.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestCountAggregate;
+
+Var
+  C : TAggregateCount;
+  I : Integer;
+  R : TFPExpressionResult;
+
+begin
+  FFunction.ResultType:=rtInteger;
+  FFunction.ParameterTypes:='';
+  C:=TAggregateCount.CreateFunction(FFunction,Nil);
+  try
+    C.Check;
+    C.InitAggregate;
+    For I:=1 to 11 do
+      C.UpdateAggregate;
+    C.GetNodeValue(R);
+    AssertEquals('Correct type',rtInteger,R.ResultType);
+    AssertEquals('Correct value',11,R.ResInteger);
+  finally
+    C.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestSumAggregate;
+
+Var
+  C : TAggregateSum;
+  V : TFPExprVariable;
+  I : Integer;
+  R : TFPExpressionResult;
+  A : TExprArgumentArray;
+
+begin
+  FFunction.ResultType:=rtInteger;
+  FFunction.ParameterTypes:='I';
+  FFunction.Name:='SUM';
+  FFunction2.ResultType:=rtInteger;
+  C:=Nil;
+  V:=TFPExprVariable.CreateIdentifier(FFunction2);
+  try
+    SetLength(A,1);
+    A[0]:=V;
+    C:=TAggregateSum.CreateFunction(FFunction,A);
+    C.Check;
+    C.InitAggregate;
+    For I:=1 to 10 do
+      begin
+      FVarValue:=I;
+      C.UpdateAggregate;
+      end;
+    C.GetNodeValue(R);
+    AssertEquals('Correct type',rtInteger,R.ResultType);
+    AssertEquals('Correct value',55,R.ResInteger);
+  finally
+    C.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestSumAggregate2;
+Var
+  C : TAggregateSum;
+  V : TFPExprVariable;
+  I : Integer;
+  R : TFPExpressionResult;
+  A : TExprArgumentArray;
+
+begin
+  FFunction.ResultType:=rtFloat;
+  FFunction.ParameterTypes:='F';
+  FFunction.Name:='SUM';
+  FFunction2.ResultType:=rtFloat;
+  C:=Nil;
+  V:=TFPExprVariable.CreateIdentifier(FFunction2);
+  try
+    SetLength(A,1);
+    A[0]:=V;
+    C:=TAggregateSum.CreateFunction(FFunction,A);
+    C.Check;
+    C.InitAggregate;
+    For I:=1 to 10 do
+      begin
+      FVarValue:=I;
+      C.UpdateAggregate;
+      end;
+    C.GetNodeValue(R);
+    AssertEquals('Correct type',rtFloat,R.ResultType);
+    AssertEquals('Correct value',55/2,R.ResFloat,0.1);
+  finally
+    C.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestAvgAggregate;
+
+Var
+  C : TAggregateAvg;
+  V : TFPExprVariable;
+  I : Integer;
+  R : TFPExpressionResult;
+  A : TExprArgumentArray;
+
+begin
+  FFunction.ResultType:=rtInteger;
+  FFunction.ParameterTypes:='F';
+  FFunction.Name:='AVG';
+  FFunction2.ResultType:=rtInteger;
+  C:=Nil;
+  V:=TFPExprVariable.CreateIdentifier(FFunction2);
+  try
+    SetLength(A,1);
+    A[0]:=V;
+    C:=TAggregateAvg.CreateFunction(FFunction,A);
+    C.Check;
+    C.InitAggregate;
+    For I:=1 to 10 do
+      begin
+      FVarValue:=I;
+      C.UpdateAggregate;
+      end;
+    C.GetNodeValue(R);
+    AssertEquals('Correct type',rtFloat,R.ResultType);
+    AssertEquals('Correct value',5.5,R.ResFloat,0.1);
+  finally
+    C.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestAvgAggregate2;
+
+Var
+  C : TAggregateAvg;
+  V : TFPExprVariable;
+  I : Integer;
+  R : TFPExpressionResult;
+  A : TExprArgumentArray;
+
+begin
+  FFunction.ResultType:=rtInteger;
+  FFunction.ParameterTypes:='F';
+  FFunction.Name:='AVG';
+  FFunction2.ResultType:=rtFloat;
+  C:=Nil;
+  V:=TFPExprVariable.CreateIdentifier(FFunction2);
+  try
+    SetLength(A,1);
+    A[0]:=V;
+    C:=TAggregateAvg.CreateFunction(FFunction,A);
+    C.Check;
+    C.InitAggregate;
+    For I:=1 to 10 do
+      begin
+      FVarValue:=I;
+      C.UpdateAggregate;
+      end;
+    C.GetNodeValue(R);
+    AssertEquals('Correct type',rtFloat,R.ResultType);
+    AssertEquals('Correct value',5.5/2,R.ResFloat,0.1);
+  finally
+    C.Free;
+  end;
+end;
+
+procedure TTestParserAggregate.TestAvgAggregate3;
+Var
+  C : TAggregateAvg;
+  V : TFPExprVariable;
+  I : Integer;
+  R : TFPExpressionResult;
+  A : TExprArgumentArray;
+
+begin
+  FFunction.ResultType:=rtInteger;
+  FFunction.ParameterTypes:='F';
+  FFunction.Name:='AVG';
+  FFunction2.ResultType:=rtFloat;
+  C:=Nil;
+  V:=TFPExprVariable.CreateIdentifier(FFunction2);
+  try
+    SetLength(A,1);
+    A[0]:=V;
+    C:=TAggregateAvg.CreateFunction(FFunction,A);
+    C.Check;
+    C.InitAggregate;
+    C.GetNodeValue(R);
+    AssertEquals('Correct type',rtFloat,R.ResultType);
+    AssertEquals('Correct value',0.0,R.ResFloat,0.1);
+  finally
+    C.Free;
+  end;
+end;
+
+{ TAggregateNode }
+
+class function TAggregateNode.IsAggregate: Boolean;
+begin
+  Result:=True
+end;
+
+function TAggregateNode.NodeType: TResultType;
+begin
+  Result:=rtInteger;
+end;
+
+procedure TAggregateNode.InitAggregate;
+begin
+  inherited InitAggregate;
+  inc(InitCount)
+end;
+
+procedure TAggregateNode.UpdateAggregate;
+begin
+  inherited UpdateAggregate;
+  inc(UpdateCount);
+end;
+
+procedure TAggregateNode.GetNodeValue(var Result: TFPExpressionResult);
+begin
+  Result.ResultType:=rtInteger;
+  Result.ResInteger:=updateCount;
+end;
+
 procedure TTestExpressionScanner.TestCreate;
 begin
   AssertEquals('Empty source','',FP.Source);
@@ -921,7 +1323,7 @@ Const
     = ('+','-','<','>','=','/',
        '*','(',')','<=','>=',
        '<>','1','''abc''','abc',',','and',
-       'or','xor','true','false','not','if','case','');
+       'or','xor','true','false','not','if','case','^','');
 
 var
   t : TTokenType;
@@ -941,28 +1343,27 @@ procedure TTestExpressionScanner.DoInvalidNumber(AString : String);
 
 begin
   FInvalidString:=AString;
-  AssertException('Invalid number "'+AString+'"',EExprScanner,@TestInvalidNumber);
+  AssertException('Invalid number "'+AString+'" ',EExprScanner,@TestInvalidNumber);
 end;
 
 procedure TTestExpressionScanner.TestNumber;
 begin
-  TestString('123',ttNumber);
+  {TestString('123',ttNumber);
   TestString('123.4',ttNumber);
   TestString('123.E4',ttNumber);
   TestString('1.E4',ttNumber);
   TestString('1e-2',ttNumber);
   DoInvalidNumber('1..1');
+}
   DoInvalidNumber('1.E--1');
-  DoInvalidNumber('.E-1');
+//  DoInvalidNumber('.E-1');
 end;
 
 procedure TTestExpressionScanner.TestInvalidCharacter;
 begin
   DoInvalidNumber('~');
-  DoInvalidNumber('^');
   DoInvalidNumber('#');
   DoInvalidNumber('$');
-  DoInvalidNumber('^');
 end;
 
 procedure TTestExpressionScanner.TestUnterminatedString;
@@ -977,6 +1378,27 @@ begin
   TestString('''s it''''''',ttString);
 end;
 
+procedure TTestExpressionScanner.TestIdentifier(Const ASource,ATokenName : string);
+
+begin
+  FP.Source:=ASource;
+  AssertEquals('Token type',ttIdentifier,FP.GetToken);
+  AssertEquals('Token name',ATokenName,FP.Token);
+end;
+
+procedure TTestExpressionScanner.TestIdentifiers;
+begin
+  TestIdentifier('a','a');
+  TestIdentifier(' a','a');
+  TestIdentifier('a ','a');
+  TestIdentifier('a^b','a');
+  TestIdentifier('a-b','a');
+  TestIdentifier('a.b','a.b');
+  TestIdentifier('"a b"','a b');
+  TestIdentifier('c."a b"','c.a b');
+  TestIdentifier('c."ab"','c.ab');
+end;
+
 procedure TTestExpressionScanner.SetUp; 
 begin
   FP:=TFPExpressionScanner.Create;
@@ -1118,15 +1540,16 @@ end;
 procedure TTestConstExprNode.TestCreateFloat;
 
 Var
-  S : String;
+  F : Double;
+  C : Integer;
 
 begin
   FN:=TFPConstExpression.CreateFloat(2.34);
   AssertEquals('Correct type',rtFloat,FN.NodeType);
   AssertEquals('Correct result',2.34,FN.ConstValue.ResFloat);
   AssertEquals('Correct result',2.34,FN.NodeValue.ResFloat);
-  Str(TExprFLoat(2.34),S);
-  AssertEquals('AsString ok',S,FN.AsString);
+  Val(FN.AsString,F,C);
+  AssertEquals('AsString ok',2.34,F,0.001);
 end;
 
 procedure TTestConstExprNode.TestCreateBoolean;
@@ -2026,6 +2449,130 @@ begin
 end;
 
 
+{ TTestPowerNode }
+
+procedure TTestPowerNode.TearDown;
+begin
+  FreeAndNil(FN);
+  inherited TearDown;
+end;
+
+procedure TTestPowerNode.Setup;
+begin
+  inherited ;
+  FE:=TFpExpressionParser.Create(Nil);
+  FE.Builtins := [bcMath];
+end;
+
+procedure TTestPowerNode.Calc(AExpr: String; Expected: Double =NaN);
+const
+  EPS = 1e-9;
+var
+  res: TFpExpressionResult;
+  x: Double;
+begin
+  FE.Expression := AExpr;
+  res:=FE.Evaluate;
+  x:= ArgToFloat(res);
+  if not IsNaN(Expected) then 
+    AssertEquals('Expression '+AExpr+' result',Expected,X,Eps);
+end;
+
+procedure TTestPowerNode.TestCalc;
+
+begin
+  Calc('2^2', Power(2, 2));
+  Calc('2^-2', Power(2, -2));
+  Calc('2^(-2)', Power(2, -2));
+  Calc('sqrt(3)^2', Power(sqrt(3), 2));
+  Calc('-sqrt(3)^2', -Power(sqrt(3), 2));
+  Calc('-2^2', -Power(2, 2));
+  Calc('(-2.0)^2', Power(-2.0, 2));
+  Calc('(-2.0)^-2', Power(-2.0, -2));
+  // Odd integer exponent
+  Calc('2^3', Power(2, 3));
+  Calc('-2^3', -Power(2, 3));
+  Calc('-2^-3', -Power(2, -3));
+  Calc('-2^(-3)', -Power(2, -3));
+  Calc('(-2.0)^3', Power(-2.0, 3));
+  Calc('(-2.0)^-3', Power(-2.0, -3));
+  // Fractional exponent
+  Calc('10^2.5', power(10, 2.5));
+  Calc('10^-2.5', Power(10, -2.5));
+  // Expressions
+  Calc('(1+1)^3', Power(1+1, 3));
+  Calc('1+2^3', 1 + Power(2, 3));
+  calc('2^3+1', Power(2, 3) + 1);
+  Calc('2^3*2', Power(2, 3) * 2);
+  Calc('2^3*-2', Power(2, 3) * -2);
+  Calc('2^(1+1)', Power(2, 1+1));
+  Calc('2^-(1+1)', Power(2, -(1+1)));
+  WriteLn;
+  // Special cases
+  Calc('0^0', power(0, 0));
+  calc('0^1', power(0, 1));
+  Calc('0^2.5', Power(0, 2.5));
+  calc('2.5^0', power(2.5, 0));
+  calc('2^3^4', 2417851639229258349412352);  // according to Wolfram Alpha, 2^(3^4)
+
+  // These expressions should throw expections
+
+  //Calc('(-10)^2.5', NaN);  // base must be positive in case of fractional exponent
+  //Calc('0^-2', NaN);       // is 1/0^2 = 1/0
+end;
+
+procedure TTestPowerNode.TestCreateInteger;
+begin
+  FN:=TFPPowerOperation.Create(CreateIntNode(4),CreateIntNode(2));
+  AssertEquals('Power has correct type',rtfloat,FN.NodeType);
+  AssertEquals('Power has correct result',16.0,FN.NodeValue.ResFloat);
+end;
+
+procedure TTestPowerNode.TestCreateFloat;
+begin
+  FN:=TFPPowerOperation.Create(CreateFloatNode(2.0),CreateFloatNode(3.0));
+  AssertEquals('Power has correct type',rtFloat,FN.NodeType);
+  AssertEquals('Power has correct result',8.0,FN.NodeValue.ResFloat);
+end;
+
+procedure TTestPowerNode.TestCreateDateTime;
+
+Var
+  D,T : TDateTime;
+
+begin
+  D:=Date;
+  T:=Time;
+  FN:=TFPPowerOperation.Create(CreateDateTimeNode(D+T),CreateDateTimeNode(T));
+  AssertNodeNotOK('No datetime Power',FN);
+end;
+
+procedure TTestPowerNode.TestCreateString;
+begin
+  FN:=TFPPowerOperation.Create(CreateStringNode('alo'),CreateStringNode('ha'));
+  AssertNodeNotOK('No string Power',FN);
+end;
+
+procedure TTestPowerNode.TestCreateBoolean;
+begin
+  FN:=TFPPowerOperation.Create(CreateBoolNode(True),CreateBoolNode(False));
+  AssertNodeNotOK('No boolean Power',FN);
+end;
+
+procedure TTestPowerNode.TestDestroy;
+begin
+  FN:=TFPPowerOperation.Create(TMyDestroyNode.CreateTest(Self),TMyDestroyNode.CreateTest(Self));
+  FreeAndNil(FN);
+  AssertEquals('Destroy called for left and right nodes',2,self.FDestroyCalled)
+end;
+
+procedure TTestPowerNode.TestAsString;
+begin
+  FN:=TFPPowerOperation.Create(CreateIntNode(1),CreateIntNode(2));
+  AssertEquals('Asstring works ok','1^2',FN.AsString);
+end;
+
+
 { TTestDivideNode }
 
 procedure TTestDivideNode.TearDown;
@@ -4196,6 +4743,114 @@ begin
   AssertEquals('Correct value',False,I.AsBoolean);
 end;
 
+procedure TTestParserVariables.DoGetBooleanVar(var Res: TFPExpressionResult;
+  ConstRef AName: ShortString);
+
+begin
+  FEventName:=AName;
+  Res.ResBoolean:=FBoolValue;
+end;
+
+procedure TTestParserVariables.TestVariable31;
+
+Var
+  I : TFPExprIdentifierDef;
+
+begin
+  I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVar);
+  AssertEquals('Correct name','a',i.Name);
+  AssertEquals('Correct type',Ord(rtBoolean),Ord(i.ResultType));
+  AssertSame(TMethod(I.OnGetVariableValue).Code,TMethod(@DoGetBooleanVar).Code);
+  FBoolValue:=True;
+  FEventName:='';
+  AssertEquals('Correct value 1',True,I.AsBoolean);
+  AssertEquals('Correct name passed','a',FEventName);
+  FBoolValue:=False;
+  FEventName:='';
+  AssertEquals('Correct value 2',False,I.AsBoolean);
+  AssertEquals('Correct name passed','a',FEventName);
+end;
+
+Var
+  FVarCallBackName:String;
+  FVarBoolValue : Boolean;
+
+procedure DoGetBooleanVar2(var Res: TFPExpressionResult; ConstRef AName: ShortString);
+
+begin
+  FVarCallBackName:=AName;
+  Res.ResBoolean:=FVarBoolValue;
+end;
+
+procedure TTestParserVariables.DoGetBooleanVarWrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
+
+begin
+  FEventName:=AName;
+  Res.ResultType:=rtInteger;
+  Res.ResInteger:=33;
+end;
+
+procedure TTestParserVariables.TestVariable32;
+Var
+  I : TFPExprIdentifierDef;
+
+begin
+  I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVar2);
+  AssertEquals('Correct name','a',i.Name);
+  AssertEquals('Correct type',Ord(rtBoolean),Ord(i.ResultType));
+  AssertSame(I.OnGetVariableValueCallBack,@DoGetBooleanVar2);
+  FVarBoolValue:=True;
+  FVarCallBackName:='';
+  AssertEquals('Correct value 1',True,I.AsBoolean);
+  AssertEquals('Correct name passed','a',FVarCallBackName);
+  FVarBoolValue:=False;
+  FVarCallBackName:='';
+  AssertEquals('Correct value 2',False,I.AsBoolean);
+  AssertEquals('Correct name passed','a',FVarCallBackName);
+end;
+
+procedure TTestParserVariables.DoTestVariable33;
+
+Var
+  B : Boolean;
+
+begin
+  B:=FTest33.AsBoolean;
+end;
+
+procedure TTestParserVariables.TestVariable33;
+
+Var
+  I : TFPExprIdentifierDef;
+
+begin
+  I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVarWrong);
+  FTest33:=I;
+  AssertException('Changing type results in exception',EExprParser,@DoTestVariable33);
+  AssertEquals('Type is unchanged',Ord(rtBoolean),Ord(i.ResultType));
+end;
+
+
+procedure DoGetBooleanVar2Wrong(var Res: TFPExpressionResult; ConstRef AName: ShortString);
+
+begin
+  FVarCallBackName:=AName;
+  Res.ResultType:=rtInteger;
+  Res.ResInteger:=34;
+end;
+
+procedure TTestParserVariables.TestVariable34;
+
+Var
+  I : TFPExprIdentifierDef;
+
+begin
+  I:=FP.Identifiers.AddVariable('a',rtBoolean,@DoGetBooleanVar2Wrong);
+  FTest33:=I;
+  AssertException('Changing type results in exception',EExprParser,@DoTestVariable33);
+  AssertEquals('Type is unchanged',Ord(rtBoolean),Ord(i.ResultType));
+end;
+
 
 
 Procedure EchoDate(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
@@ -4937,6 +5592,7 @@ procedure TTestBuiltins.Setup;
 begin
   inherited Setup;
   FM:=TExprBuiltInManager.Create(Nil);
+  FValue:=0;
 end;
 
 procedure TTestBuiltins.Teardown;
@@ -4945,7 +5601,7 @@ begin
   inherited Teardown;
 end;
 
-procedure TTestBuiltins.SetExpression(Const AExpression : String);
+procedure TTestBuiltins.SetExpression(const AExpression: String);
 
 Var
   Msg : String;
@@ -5030,11 +5686,41 @@ begin
   AssertDatetimeResult(AResult);
 end;
 
+procedure TTestBuiltins.AssertAggregateExpression(const AExpression: String;
+  AResult: Int64; AUpdateCount: integer);
+begin
+  FP.BuiltIns:=AllBuiltIns;
+  SetExpression(AExpression);
+  AssertEquals('Has aggregate',True,FP.ExprNode.HasAggregate);
+  FP.InitAggregate;
+  While AUpdateCount>0 do
+    begin
+    FP.UpdateAggregate;
+    Dec(AUpdateCount);
+    end;
+  AssertResult(AResult);
+end;
+
+procedure TTestBuiltins.AssertAggregateExpression(const AExpression: String;
+  AResult: TExprFloat; AUpdateCount: integer);
+begin
+  FP.BuiltIns:=AllBuiltIns;
+  SetExpression(AExpression);
+  AssertEquals('Has aggregate',True,FP.ExprNode.HasAggregate);
+  FP.InitAggregate;
+  While AUpdateCount>0 do
+    begin
+    FP.UpdateAggregate;
+    Dec(AUpdateCount);
+    end;
+  AssertResult(AResult);
+end;
+
 procedure TTestBuiltins.TestRegister;
 
 begin
   RegisterStdBuiltins(FM);
-  AssertEquals('Correct number of identifiers',64,FM.IdentifierCount);
+  AssertEquals('Correct number of identifiers',69,FM.IdentifierCount);
   Assertvariable('pi',rtFloat);
   AssertFunction('cos','F','F',bcMath);
   AssertFunction('sin','F','F',bcMath);
@@ -5099,6 +5785,11 @@ begin
   AssertFunction('strtotimedef','D','SD',bcConversion);
   AssertFunction('strtodatetime','D','S',bcConversion);
   AssertFunction('strtodatetimedef','D','SD',bcConversion);
+  AssertFunction('sum','F','F',bcAggregate);
+  AssertFunction('count','I','',bcAggregate);
+  AssertFunction('avg','F','F',bcAggregate);
+  AssertFunction('min','F','F',bcAggregate);
+  AssertFunction('max','F','F',bcAggregate);
 end;
 
 procedure TTestBuiltins.TestVariablepi;
@@ -5549,6 +6240,59 @@ begin
   AssertExpression('StrToDateTimeDef('''+S+''',S)',T);
 end;
 
+procedure TTestBuiltins.TestFunctionAggregateSum;
+begin
+  FP.Identifiers.AddIntegerVariable('S',2);
+  AssertAggregateExpression('sum(S)',10.0,5);
+end;
+
+procedure TTestBuiltins.TestFunctionAggregateCount;
+begin
+  AssertAggregateExpression('count',5,5);
+end;
+
+
+procedure TTestBuiltins.DoAverage(var Result: TFPExpressionResult; ConstRef
+  AName: ShortString);
+
+begin
+  Inc(FValue);
+  Result.ResInteger:=FValue;
+  Result.ResultType:=rtInteger;
+end;
+
+procedure TTestBuiltins.DoSeries(var Result: TFPExpressionResult; ConstRef
+  AName: ShortString);
+
+Const
+  Values : Array[1..10] of double =
+  (1.3,1.8,1.1,9.9,1.4,2.4,5.8,6.5,7.8,8.1);
+
+
+begin
+  Inc(FValue);
+  Result.ResFloat:=Values[FValue];
+  Result.ResultType:=rtFloat;
+end;
+
+procedure TTestBuiltins.TestFunctionAggregateAvg;
+begin
+  FP.Identifiers.AddVariable('S',rtInteger,@DoAverage);
+  AssertAggregateExpression('avg(S)',5.5,10);
+end;
+
+procedure TTestBuiltins.TestFunctionAggregateMin;
+begin
+  FP.Identifiers.AddVariable('S',rtFloat,@DoSeries);
+  AssertAggregateExpression('Min(S)',1.1,10);
+end;
+
+procedure TTestBuiltins.TestFunctionAggregateMax;
+begin
+  FP.Identifiers.AddVariable('S',rtFloat,@DoSeries);
+  AssertAggregateExpression('Max(S)',9.9,10);
+end;
+
 { TTestNotNode }
 
 procedure TTestNotNode.TearDown;
@@ -5989,12 +6733,13 @@ initialization
                  TTestLessThanNode,TTestLessThanEqualNode,
                  TTestLargerThanNode,TTestLargerThanEqualNode,
                  TTestAddNode,TTestSubtractNode,
-                 TTestMultiplyNode,TTestDivideNode,
+                 TTestMultiplyNode,TTestDivideNode,TTestPowerNode,
                  TTestIntToFloatNode,TTestIntToDateTimeNode,
                  TTestFloatToDateTimeNode,
                  TTestParserExpressions, TTestParserBooleanOperations,
                  TTestParserOperands, TTestParserTypeMatch,
                  TTestParserVariables,TTestParserFunctions,
+                 TTestParserAggregate,
                  TTestBuiltinsManager,TTestBuiltins]);
 end.
 

packages/fcl-db/fpmake.pp

@@ -14,7 +14,6 @@ const
   SqliteOSes          = [aix,beos,haiku,linux,freebsd,darwin,iphonesim,netbsd,openbsd,solaris,win32,win64,wince,android,dragonfly];
   DBaseOSes           = [aix,beos,haiku,linux,freebsd,darwin,iphonesim,netbsd,openbsd,solaris,win32,win64,wince,android,os2,dragonfly];
   MSSQLOSes           = [beos,haiku,linux,freebsd,netbsd,openbsd,solaris,win32,win64,android,dragonfly];
-  SqldbWithoutOracleOSes   = [win64];
 
 
 Var
@@ -47,7 +46,7 @@ begin
     P.SourcePath.Add('src/sqldb/mysql', SqldbConnectionOSes);
     P.SourcePath.Add('src/sqldb/odbc', SqldbConnectionOSes);
     P.SourcePath.Add('src/sqldb/examples', SqldbConnectionOSes);
-    P.SourcePath.Add('src/sqldb/oracle', SqldbConnectionOSes-SqldbWithoutOracleOSes);
+    P.SourcePath.Add('src/sqldb/oracle', SqldbConnectionOSes);
     P.SourcePath.Add('src/sqldb/mssql', MSSQLOSes);
     P.SourcePath.Add('src/sdf');
     P.SourcePath.Add('src/json');
@@ -74,7 +73,7 @@ begin
     P.Dependencies.Add('ibase', SqldbConnectionOSes);
     P.Dependencies.Add('mysql', SqldbConnectionOSes);
     P.Dependencies.Add('odbc', SqldbConnectionOSes);
-    P.Dependencies.Add('oracle', SqldbConnectionOSes-SqldbWithoutOracleOSes);
+    P.Dependencies.Add('oracle', SqldbConnectionOSes);
     P.Dependencies.Add('postgres', SqldbConnectionOSes);
     P.Dependencies.Add('sqlite', SqldbConnectionOSes+SqliteOSes);
     P.Dependencies.Add('dblib', MSSQLOSes);
@@ -450,7 +449,7 @@ begin
           AddUnit('fpddsqldb');
           AddUnit('odbcconn');
         end;
-    T:=P.Targets.AddUnit('fpddoracle.pp', DatadictOSes-SqldbWithoutOracleOSes);
+    T:=P.Targets.AddUnit('fpddoracle.pp', DatadictOSes);
       with T.Dependencies do
         begin
           AddUnit('sqldb');
@@ -474,7 +473,7 @@ begin
           AddUnit('fpddsqldb');
           AddUnit('mssqlconn');
         end;
-    T:=P.Targets.AddUnit('fpddregstd.pp', (DatadictOSes*MSSQLOses)-SqldbWithoutOracleOSes);
+    T:=P.Targets.AddUnit('fpddregstd.pp', (DatadictOSes*MSSQLOses));
       with T.Dependencies do
         begin
           AddUnit('fpdatadict');
@@ -693,7 +692,7 @@ begin
           AddUnit('bufdataset');
           AddUnit('dbconst');
         end;
-    T:=P.Targets.AddUnit('oracleconnection.pp', SqldbConnectionOSes-SqldbWithoutOracleOSes);
+    T:=P.Targets.AddUnit('oracleconnection.pp', SqldbConnectionOSes);
     T.ResourceStrings:=true;
       with T.Dependencies do
         begin
@@ -817,7 +816,3 @@ begin
   Installer.Run;
 end.
 {$endif ALLPACKAGES}
-
-
-
-

packages/fcl-db/src/Dataset.txt

@@ -43,7 +43,7 @@ The following constants are userd when handling this array:
 
 FBufferCount :   The number of buffers allocated, minus one.
 FRecordCount :   The number of buffers that is actually filled in.
-FActiveBuffer :  The index of the active record in TDataset.
+FActiveRecord :  The index of the active record in TDataset.
 FCurrentRecord : The index of the supposedly active record in the underlying
                  dataset (ie. the index in the last call to SetToInternalRecord)
                  Call CursorPosChanged to reset FCurrentRecord if the active
@@ -60,7 +60,7 @@ So the following picture follows from this:
    ...
 |               |
 +---------------+
-| FActivebuffer |
+| FActiveRecord |
 +---------------+
 |               |
     ...

packages/fcl-db/src/base/bufdataset.pas

@@ -159,7 +159,7 @@ type
     procedure GotoBookmark(const ABookmark : PBufBookmark); virtual; abstract;
     function BookmarkValid(const ABookmark: PBufBookmark): boolean; virtual;
     function CompareBookmarks(const ABookmark1, ABookmark2 : PBufBookmark) : integer; virtual;
-    function SameBookmarks(const ABookmark1, ABookmark2 : PBufBookmark) : boolean; inline;
+    function SameBookmarks(const ABookmark1, ABookmark2 : PBufBookmark) : boolean; virtual;
 
     procedure InitialiseIndex; virtual; abstract;
 
@@ -228,6 +228,7 @@ type
     procedure StoreSpareRecIntoBookmark(const ABookmark: PBufBookmark); override;
     procedure GotoBookmark(const ABookmark : PBufBookmark); override;
     function CompareBookmarks(const ABookmark1, ABookmark2: PBufBookmark): integer; override;
+    function SameBookmarks(const ABookmark1, ABookmark2 : PBufBookmark) : boolean; override;
     procedure InitialiseIndex; override;
 
     procedure InitialiseSpareRecord(const ASpareRecord : TRecordBuffer); override;
@@ -496,6 +497,7 @@ type
     function GetRecordUpdateBuffer(const ABookmark : TBufBookmark; IncludePrior : boolean = false; AFindNext : boolean = false) : boolean;
     function GetRecordUpdateBufferCached(const ABookmark : TBufBookmark; IncludePrior : boolean = false) : boolean;
     function GetActiveRecordUpdateBuffer : boolean;
+    procedure CancelRecordUpdateBuffer(AUpdateBufferIndex: integer; var ABookmark: TBufBookmark);
     procedure ParseFilter(const AFilter: string);
 
     function GetIndexDefs : TIndexDefs;
@@ -575,6 +577,7 @@ type
     procedure ApplyUpdates; virtual; overload;
     procedure ApplyUpdates(MaxErrors: Integer); virtual; overload;
     procedure MergeChangeLog;
+    procedure RevertRecord;
     procedure CancelUpdates; virtual;
     destructor Destroy; override;
     function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions) : boolean; override;
@@ -1677,6 +1680,11 @@ begin
     Result := -Result;
 end;
 
+function TDoubleLinkedBufIndex.SameBookmarks(const ABookmark1, ABookmark2: PBufBookmark): boolean;
+begin
+  Result := Assigned(ABookmark1) and Assigned(ABookmark2) and (ABookmark1^.BookmarkData = ABookmark2^.BookmarkData);
+end;
+
 procedure TDoubleLinkedBufIndex.InitialiseIndex;
 begin
   // Do nothing
@@ -2401,90 +2409,106 @@ begin
   raise EDatabaseError.Create(SApplyRecNotSupported);
 end;
 
-procedure TCustomBufDataset.CancelUpdates;
-var StoreRecBM     : TBufBookmark;
-  procedure CancelUpdBuffer(var AUpdBuffer : TRecUpdateBuffer);
-  var
-    TmpBuf         : TRecordBuffer;
-    StoreUpdBuf    : integer;
-    Bm             : TBufBookmark;
-  begin
-    with AUpdBuffer do
+procedure TCustomBufDataset.CancelRecordUpdateBuffer(AUpdateBufferIndex: integer; var ABookmark: TBufBookmark);
+var
+  ARecordBuffer: TRecordBuffer;
+  NBookmark    : TBufBookmark;
+  i            : integer;
+begin
+  with FUpdateBuffer[AUpdateBufferIndex] do
+    if Assigned(BookmarkData.BookmarkData) then // this is used to exclude buffers which are already handled
       begin
-      if Not assigned(BookmarkData.BookmarkData) then
-        exit;// this is used to exclude buffers which are already handled
-      Case UpdateKind of
-      ukModify:
-        begin
-        FCurrentIndex.GotoBookmark(@BookmarkData);
-        move(TRecordBuffer(OldValuesBuffer)^,TRecordBuffer(FCurrentIndex.CurrentBuffer)^,FRecordSize);
-        FreeRecordBuffer(OldValuesBuffer);
-        end;
-      ukDelete:
-        if (assigned(OldValuesBuffer)) then
+      case UpdateKind of
+        ukModify:
           begin
-          FCurrentIndex.GotoBookmark(@NextBookmarkData);
-          FCurrentIndex.InsertRecordBeforeCurrentRecord(TRecordBuffer(BookmarkData.BookmarkData));
-          FCurrentIndex.ScrollBackward;
-          move(TRecordBuffer(OldValuesBuffer)^,TRecordBuffer(FCurrentIndex.CurrentBuffer)^,FRecordSize);
-
-          {for x := length(FUpdateBuffer)-1 downto 0 do
-            begin
-            if (FUpdateBuffer[x].UpdateKind=ukDelete) and FCurrentIndex.SameBookmarks(@FUpdateBuffer[x].NextBookmarkData,@BookmarkData) then
-              CancelUpdBuffer(FUpdateBuffer[x]);
-            end;}
+          FCurrentIndex.GotoBookmark(@BookmarkData);
+          move(TRecordBuffer(OldValuesBuffer)^, TRecordBuffer(FCurrentIndex.CurrentBuffer)^, FRecordSize);
           FreeRecordBuffer(OldValuesBuffer);
-          inc(FBRecordCount);
-          end  ;
-      ukInsert:
-        begin
-        // Process all update buffers linked to this record before this record is removed
-        StoreUpdBuf:=FCurrentUpdateBuffer;
-        Bm := BookmarkData;
-        BookmarkData.BookmarkData:=nil; // Avoid infinite recursion...
-        if GetRecordUpdateBuffer(Bm,True,False) then
-          begin
-          repeat
-            if (FCurrentUpdateBuffer<>StoreUpdBuf) then
-              CancelUpdBuffer(FUpdateBuffer[FCurrentUpdateBuffer]);
-          until not GetRecordUpdateBuffer(Bm,True,True);
           end;
-        FCurrentUpdateBuffer:=StoreUpdBuf;
-
-        FCurrentIndex.GotoBookmark(@Bm);
-        TmpBuf:=FCurrentIndex.CurrentRecord;
-        // resync won't work if the currentbuffer is freed...
-        if FCurrentIndex.SameBookmarks(@Bm,@StoreRecBM) then with FCurrentIndex do
+        ukDelete:
+          if (assigned(OldValuesBuffer)) then
+            begin
+            FCurrentIndex.GotoBookmark(@NextBookmarkData);
+            FCurrentIndex.InsertRecordBeforeCurrentRecord(TRecordBuffer(BookmarkData.BookmarkData));
+            FCurrentIndex.ScrollBackward;
+            move(TRecordBuffer(OldValuesBuffer)^, TRecordBuffer(FCurrentIndex.CurrentBuffer)^, FRecordSize);
+            FreeRecordBuffer(OldValuesBuffer);
+            inc(FBRecordCount);
+            end;
+        ukInsert:
           begin
-          GotoBookmark(@StoreRecBM);
-          if ScrollForward = grEOF then
-            if ScrollBackward = grBOF then
-              ScrollLast;  // last record will be removed from index, so move to spare record
-          StoreCurrentRecIntoBookmark(@StoreRecBM);
+          FCurrentIndex.GotoBookmark(@BookmarkData);
+          ARecordBuffer := FCurrentIndex.CurrentRecord;
+
+          // Find next record's bookmark
+          FCurrentIndex.DoScrollForward;
+          FCurrentIndex.StoreCurrentRecIntoBookmark(@NBookmark);
+          // Process (re-link) all update buffers linked to this record before this record is removed
+          //  Modified record #1, which is later deleted can be linked to another inserted record #2. In this case deleted record #1 precedes inserted #2 in update buffer.
+          //  Deleted records, which are deleted after this record is inserted are in update buffer after this record.
+          //  if we need revert inserted record which is linked from another deleted records, then we must re-link these records
+          for i:=0 to high(FUpdateBuffer) do
+            if (FUpdateBuffer[i].UpdateKind = ukDelete) and
+               (FUpdateBuffer[i].NextBookmarkData.BookmarkData = BookmarkData.BookmarkData) then
+              FUpdateBuffer[i].NextBookmarkData := NBookmark;
+
+          // ReSync won't work if the CurrentBuffer is freed ... so in this case move to next/prior record
+          if FCurrentIndex.SameBookmarks(@BookmarkData,@ABookmark) then with FCurrentIndex do
+            begin
+            GotoBookmark(@ABookmark);
+            if ScrollForward = grEOF then
+              if ScrollBackward = grBOF then
+                ScrollLast;  // last record will be removed from index, so move to spare record
+            StoreCurrentRecIntoBookmark(@ABookmark);
+            end;
+
+          RemoveRecordFromIndexes(BookmarkData);
+          FreeRecordBuffer(ARecordBuffer);
+          dec(FBRecordCount);
           end;
-        RemoveRecordFromIndexes(Bm);
-        FreeRecordBuffer(TmpBuf);
-        dec(FBRecordCount);
-        end;
       end;
-      BookmarkData.BookmarkData:=nil;
+      BookmarkData.BookmarkData := nil;
       end;
-  end;
+end;
 
-var r              : Integer;
+procedure TCustomBufDataset.RevertRecord;
+var
+  ABookmark : TBufBookmark;
+begin
+  CheckBrowseMode;
+
+  if GetActiveRecordUpdateBuffer then
+  begin
+    FCurrentIndex.StoreCurrentRecIntoBookmark(@ABookmark);
+
+    CancelRecordUpdateBuffer(FCurrentUpdateBuffer, ABookmark);
+
+    // remove update record of current record from update-buffer array
+    Move(FUpdateBuffer[FCurrentUpdateBuffer+1], FUpdateBuffer[FCurrentUpdateBuffer], (High(FUpdateBuffer)-FCurrentUpdateBuffer)*SizeOf(TRecUpdateBuffer));
+    SetLength(FUpdateBuffer, High(FUpdateBuffer));
+
+    FCurrentIndex.GotoBookmark(@ABookmark);
+
+    Resync([]);
+  end;
+end;
 
+procedure TCustomBufDataset.CancelUpdates;
+var
+  ABookmark : TBufBookmark;
+  r         : Integer;
 begin
   CheckBrowseMode;
 
   if Length(FUpdateBuffer) > 0 then
     begin
-    FCurrentIndex.StoreCurrentRecIntoBookmark(@StoreRecBM);
-    for r := Length(FUpdateBuffer) - 1 downto 0 do
-      CancelUpdBuffer(FUpdateBuffer[r]);
+    FCurrentIndex.StoreCurrentRecIntoBookmark(@ABookmark);
 
-    SetLength(FUpdateBuffer,0);
+    for r := High(FUpdateBuffer) downto 0 do
+      CancelRecordUpdateBuffer(r, ABookmark);
+    SetLength(FUpdateBuffer, 0);
     
-    FCurrentIndex.GotoBookmark(@StoreRecBM);
+    FCurrentIndex.GotoBookmark(@ABookmark);
     
     Resync([]);
     end;
@@ -2635,7 +2659,7 @@ begin
       FAutoIncField.AsInteger := FAutoIncValue;
       inc(FAutoIncValue);
       end;
-    // The active buffer is the newly created TDataset record,
+    // The active buffer is the newly created TDataSet record,
     // from which the bookmark is set to the record where the new record should be
     // inserted
     ABookmark := PBufBookmark(ActiveBuffer + FRecordSize);
@@ -2653,12 +2677,13 @@ begin
           // insert (before current record)
           FIndexes[i].GotoBookmark(ABookmark);
 
+        // insert new record before current record
         FIndexes[i].InsertRecordBeforeCurrentRecord(ABuff);
         // newly inserted record becomes current record
         FIndexes[i].ScrollBackward;
       end;
 
-    // Link the newly created record buffer to the newly created TDataset record
+    // Link the newly created record buffer to the newly created TDataSet record
     FCurrentIndex.StoreCurrentRecIntoBookmark(ABookmark);
     ABookmark^.BookmarkFlag := bfInserted;
 
@@ -2679,12 +2704,11 @@ begin
 
     if State = dsEdit then
       begin
-      // Create an oldvalues buffer with the old values of the record
-      FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := IntAllocRecordBuffer;
-      with FCurrentIndex do
-        // Move only the real data
-        move(CurrentBuffer^,FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer^,FRecordSize);
+      // Create an OldValues buffer with the old values of the record
       FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind := ukModify;
+      FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := IntAllocRecordBuffer;
+      // Move only the real data
+      move(FCurrentIndex.CurrentBuffer^, FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer^, FRecordSize);
       end
     else
       begin
@@ -2808,7 +2832,7 @@ begin
     Result := 0
   else
     begin
-    InternalSetToRecord(ActiveBuffer);
+    UpdateCursorPos;
     Result := FCurrentIndex.RecNo;
     end;
 end;
@@ -3018,12 +3042,10 @@ procedure TCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketReader);
       begin
       AStoreUpdBuf:=FCurrentUpdateBuffer;
       if GetRecordUpdateBuffer(AUpdBuffer.BookmarkData,True,False) then
-        begin
         repeat
           if FCurrentIndex.SameBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].NextBookmarkData, @AUpdBuffer.BookmarkData) then
             StoreUpdateBuffer(FUpdateBuffer[FCurrentUpdateBuffer], ARowState);
-        until not GetRecordUpdateBuffer(AUpdBuffer.BookmarkData,True,True)
-        end;
+        until not GetRecordUpdateBuffer(AUpdBuffer.BookmarkData,True,True);
       FCurrentUpdateBuffer:=AStoreUpdBuf;
       AThisRowState := [rsvDeleted];
       end
@@ -3036,16 +3058,16 @@ procedure TCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketReader);
       FDatasetReader.StoreRecord(AThisRowState,FCurrentUpdateBuffer);
   end;
 
-  procedure HandleUpdateBuffersFromRecord(AFirstCall : boolean;ARecBookmark : TBufBookmark; var ARowState: TRowState);
+  procedure HandleUpdateBuffersFromRecord(AFindNext : boolean; ARecBookmark : TBufBookmark; var ARowState: TRowState);
   var StoreUpdBuf1,StoreUpdBuf2 : Integer;
   begin
-    if AFirstCall then ARowState:=[];
-    if GetRecordUpdateBuffer(ARecBookmark,True,not AFirstCall) then
+    if not AFindNext then ARowState:=[];
+    if GetRecordUpdateBuffer(ARecBookmark,True,AFindNext) then
       begin
       if FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind=ukDelete then
         begin
         StoreUpdBuf1:=FCurrentUpdateBuffer;
-        HandleUpdateBuffersFromRecord(False,ARecBookmark,ARowState);
+        HandleUpdateBuffersFromRecord(True,ARecBookmark,ARowState);
         StoreUpdBuf2:=FCurrentUpdateBuffer;
         FCurrentUpdateBuffer:=StoreUpdBuf1;
         StoreUpdateBuffer(FUpdateBuffer[StoreUpdBuf1], ARowState);
@@ -3054,7 +3076,7 @@ procedure TCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketReader);
       else
         begin
         StoreUpdateBuffer(FUpdateBuffer[FCurrentUpdateBuffer], ARowState);
-        HandleUpdateBuffersFromRecord(False,ARecBookmark,ARowState);
+        HandleUpdateBuffersFromRecord(True,ARecBookmark,ARowState);
         end;
       end
   end;
@@ -3078,7 +3100,9 @@ begin
       begin
       RowState:=[];
       FCurrentIndex.StoreCurrentRecIntoBookmark(ABookmark);
-      HandleUpdateBuffersFromRecord(True,ABookmark^,RowState);
+      // updates related to current record are stored first
+      HandleUpdateBuffersFromRecord(False,ABookmark^,RowState);
+      // now store current record
       FFilterBuffer:=FCurrentIndex.CurrentBuffer;
       if RowState=[] then
         FDatasetReader.StoreRecord([])
@@ -3094,7 +3118,7 @@ begin
       end;
     // There could be an update buffer linked to the last (spare) record
     FCurrentIndex.StoreSpareRecIntoBookmark(ABookmark);
-    HandleUpdateBuffersFromRecord(True,ABookmark^,RowState);
+    HandleUpdateBuffersFromRecord(False,ABookmark^,RowState);
 
     RestoreState(SavedState);
 
@@ -3233,10 +3257,9 @@ end;
 procedure TCustomBufDataset.IntLoadRecordsFromFile;
 
 var SavedState      : TDataSetState;
-    AddRecordBuffer : boolean;
     ARowState       : TRowState;
     AUpdOrder       : integer;
-    x               : integer;
+    i               : integer;
 
 begin
   CheckBiDirectional;
@@ -3274,9 +3297,6 @@ begin
       FDatasetReader.RestoreRecord;
       FIndexes[0].AddRecord;
       inc(FBRecordCount);
-
-      AddRecordBuffer:=False;
-
       end
     else if rsvDeleted in ARowState then
       begin
@@ -3297,16 +3317,11 @@ begin
       FIndexes[0].RemoveRecordFromIndex(FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
       FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].NextBookmarkData);
 
-      for x := FCurrentUpdateBuffer+1 to length(FUpdateBuffer)-1 do
-        if FIndexes[0].SameBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData,@FUpdateBuffer[x].NextBookmarkData) then
-          FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[x].NextBookmarkData);
-
-      AddRecordBuffer:=False;
+      for i := FCurrentUpdateBuffer+1 to high(FUpdateBuffer) do
+        if FIndexes[0].SameBookmarks(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData, @FUpdateBuffer[i].NextBookmarkData) then
+          FIndexes[0].StoreSpareRecIntoBookmark(@FUpdateBuffer[i].NextBookmarkData);
       end
     else
-      AddRecordBuffer:=True;
-
-    if AddRecordBuffer then
       begin
       FFilterBuffer:=FIndexes[0].SpareBuffer;
       fillchar(FFilterBuffer^,FNullmaskSize,0);

packages/fcl-db/src/base/database.inc

@@ -525,10 +525,12 @@ begin
     begin
     GetLoginParams(ADatabaseName, AUserName, APassword);
     if Assigned(FOnLogin) then
-      FOnLogin(Self, AUserName, APassword)
+      FOnLogin(Self, AUserName, APassword) // by value
     else if Assigned(LoginDialogExProc) then
-      LoginDialogExProc(ADatabaseName, AUserName, APassword, False);
-    SetLoginParams(ADatabaseName, AUserName, APassword);
+      begin
+      LoginDialogExProc(ADatabaseName, AUserName, APassword, False); // by reference
+      SetLoginParams(ADatabaseName, AUserName, APassword);
+      end;
     end;
 end;
 
@@ -572,7 +574,7 @@ begin
   if IsPublishedProp(Self,'UserName') then
     AUserName := GetStrProp(Self,'UserName');
   if IsPublishedProp(Self,'Password') then
-    APassword := 'Password';
+    APassword := GetStrProp(Self,'Password');
 end;
 
 procedure TCustomConnection.SetLoginParams(const ADatabaseName, AUserName, APassword: string);

packages/fcl-db/src/base/dataset.inc

@@ -763,20 +763,20 @@ begin
   If FRecordCount>0 Then SetCurrentRecord(FRecordCount-1);
   Result:=GetRecord(FBuffers[FBufferCount],gmNext,True)=grOK;
 
-  if result then
+  if Result then
     begin
       If FRecordCount=0 then ActivateBuffers;
       if FRecordCount=FBufferCount then
         ShiftBuffersBackward
       else
         begin
-          inc(FRecordCount);
+          Inc(FRecordCount);
           FCurrentRecord:=FRecordCount - 1;
           ExchangeBuffers(FBuffers[FCurrentRecord],FBuffers[FBufferCount]);
         end;
     end
   else
-    cursorposchanged;
+    CursorPosChanged;
 {$ifdef dsdebug}
   Writeln ('Result getting next record : ',Result);
 {$endif}
@@ -805,16 +805,16 @@ begin
   CheckBiDirectional;
   If FRecordCount>0 Then SetCurrentRecord(0);
   Result:=GetRecord(FBuffers[FBufferCount],gmPrior,True)=grOK;
-  if result then
+  if Result then
     begin
       If FRecordCount=0 then ActivateBuffers;
       ShiftBuffersForward;
 
       if FRecordCount<FBufferCount then
-        inc(FRecordCount);
+        Inc(FRecordCount);
     end
   else
-    cursorposchanged;
+    CursorPosChanged;
 {$ifdef dsdebug}
   Writeln ('Result getting prior record : ',Result);
 {$endif}
@@ -894,30 +894,30 @@ begin
   else
     Insert;
 
-  for i := 0 to ValuesSize-1 do with values[i] do
-    fields[i].AssignValue(values[i]);
+  for i := 0 to ValuesSize-1 do
+    Fields[i].AssignValue(Values[i]);
   Post;
 
 end;
 
-procedure TDataSet.InitFieldDefsFromfields;
+procedure TDataSet.InitFieldDefsFromFields;
 var i : integer;
 
 begin
-  if FieldDefs.count = 0 then
+  if FieldDefs.Count = 0 then
     begin
     FieldDefs.BeginUpdate;
     try
-      for i := 0 to Fields.Count-1 do with fields[i] do
+      for i := 0 to Fields.Count-1 do with Fields[i] do
         if not (FieldKind in [fkCalculated,fkLookup]) then // Do not add fielddefs for calculated/lookup fields.
           begin
           FFieldDef:=FieldDefs.FieldDefClass.Create(FieldDefs,FieldName,DataType,Size,Required,FieldDefs.Count+1);
           with FFieldDef do
             begin
-            if Required then Attributes := attributes + [faRequired];
-            if ReadOnly then Attributes := attributes + [faReadOnly];
-            if DataType = ftBCD then precision := (fields[i] as TBCDField).Precision
-            else if DataType = ftFMTBcd then precision := (fields[i] as TFMTBCDField).Precision;
+            if Required then Attributes := Attributes + [faRequired];
+            if ReadOnly then Attributes := Attributes + [faReadOnly];
+            if DataType = ftBCD then Precision := (Fields[i] as TBCDField).Precision
+            else if DataType = ftFMTBcd then Precision := (Fields[i] as TFMTBCDField).Precision;
             end;
           end;
     finally
@@ -1148,7 +1148,7 @@ begin
     for j := 0 to TDataSource(FDataSources[i]).DataLinks.Count - 1 do
       begin
       DataLink:=TDataLink(TDataSource(FDataSources[i]).DataLinks[j]);
-      if DataLink.BufferCount>ABufferCount then
+      if ABufferCount<DataLink.BufferCount then
         ABufferCount:=DataLink.BufferCount;
       end;
 
@@ -1200,11 +1200,11 @@ begin
 {$ifdef dsdebug}
     Writeln ('   Reallocating memory :',(Value+1)*SizeOf(TRecordBuffer));
 {$endif}
-    ReAllocMem(FBuffers,(Value+1)*SizeOf(PChar));
+    ReAllocMem(FBuffers,(Value+1)*SizeOf(TRecordBuffer));
 {$ifdef dsdebug}
     Writeln ('   Filling memory :',(Value+1-FBufferCount)*SizeOf(TRecordBuffer));
 {$endif}
-    inc(FBufferCount); // Cause FBuffers[FBufferCount] is already allocated
+    Inc(FBufferCount); // Cause FBuffers[FBufferCount] is already allocated
     FillChar(FBuffers[FBufferCount],(Value+1-FBufferCount)*SizeOf(TRecordBuffer),#0);
 {$ifdef dsdebug}
     Writeln ('   Filled memory');
@@ -1286,7 +1286,7 @@ begin
       bfBOF : InternalFirst;
       bfEOF : InternalLast;
       end;
-    FCurrentRecord:=index;
+    FCurrentRecord:=Index;
     end;
 end;
 
@@ -2165,7 +2165,7 @@ begin
     inc(i);
   FActiveRecord := i;
 // Fill the rest of the buffer
-  getnextrecords;
+  GetNextRecords;
 // If the buffer is not full yet, try to fetch some more prior records
   if FRecordCount < FBufferCount then inc(FActiveRecord,getpriorrecords);
 // That's all folks!

packages/fcl-db/src/base/dsparams.inc

@@ -1076,7 +1076,7 @@ Var
   S : TFileStream;
 
 begin
-  S:=TFileStream.Create(FileName,fmOpenRead);
+  S:=TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
   Try
     LoadFromStream(S,BlobType);
   Finally
@@ -1096,8 +1096,8 @@ begin
     Position:=0;
     SetLength(Temp,Size);
     ReadBuffer(Pointer(Temp)^,Size);
-    FValue:=Temp;
     end;
+  Value:=Temp;
 end;
 
 Procedure TParam.SetBlobData(Buffer: Pointer; ASize: Integer);

packages/fcl-db/src/base/fields.inc

@@ -1481,12 +1481,13 @@ var L : Longint;
     P : PLongint;
 
 begin
+  L:=0;
   P:=@L;
   Result:=GetData(P);
   If Result then
-    Case Datatype of
-      ftInteger,ftAutoinc  : AValue:=Plongint(P)^;
-      ftWord               : AValue:=Pword(P)^;
+    Case DataType of
+      ftInteger,ftAutoInc  : AValue:=PLongint(P)^;
+      ftWord               : AValue:=PWord(P)^;
       ftSmallint           : AValue:=PSmallint(P)^;
     end;
 end;

packages/fcl-db/src/sqldb/interbase/fbadmin.pp

@@ -27,7 +27,7 @@ unit FBAdmin;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 {$mode objfpc}{$H+}
@@ -47,11 +47,11 @@ uses
 
 type
   TIBBackupOption=(IBBkpVerbose,IBBkpIgnoreChecksums,IBBkpIgnoreLimbo,IBBkpMetadataOnly,
-     IBBkpNoGarbageCollect,IBBkpOldDescriptions,IBBkpNonTransportable,IBBkpConvert);
+     IBBkpNoGarbageCollect,IBBkpOldDescriptions,IBBkpNonTransportable,IBBkpConvert,IBBkpWait);
   TIBBackupOptions= set of TIBBackupOption;
   TIBRestoreOption=(IBResVerbose,IBResDeactivateIdx,IBResNoShadow,IBResNoValidity,
      IBResOneAtaTime,IBResReplace,IBResCreate,IBResUseAllSpace,IBResAMReadOnly,IBResAMReadWrite,
-     IBFixFssData, IBFixFssMeta);
+     IBFixFssData, IBFixFssMeta,IBResWait);
   TIBRestoreOptions= set of TIBRestoreOption;
   TServiceProtocol=(IBSPLOCAL,IBSPTCPIP,IBSPNETBEUI,IBSPNAMEDPIPE);
   TIBOnOutput= procedure(Sender: TObject; msg: string; IBAdminAction: string) of object;
@@ -82,6 +82,7 @@ type
     FSvcHandle: isc_svc_handle;
     FUseExceptions: boolean;
     FUser: string;
+    FWaitInterval: Integer;
     function CheckConnected(ProcName: string):boolean;
     procedure CheckError(ProcName : string; Status : PISC_STATUS);
     function GetDBInfo:boolean;
@@ -94,7 +95,6 @@ type
     function IBSPBParamSerialize(isccode:byte;value:longint):string;
     function MakeBackupOptions(options:TIBBackupOptions):longint;
     function MakeRestoreOptions(options:TIBRestoreOptions):longint;
-
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
@@ -140,6 +140,12 @@ type
     function GetUsers(Users:TStrings):boolean;
     //Get database server log file
     function GetDatabaseLog:boolean;
+    // For Backup, Restore this will check if the service call is still running.
+    function ServiceRunning: Boolean;
+    // Wait till the service stops running, or until aTimeout (in milliseconds) is reached.
+    // Return true if the service stopped, false if timeout reached.
+    // WaitInterval is the interval (in milliseconds) between ServiceRunning calls.
+    function WaitForServiceCompletion(aTimeOut: Integer): Boolean;
     //Get database statistics
     function GetDatabaseStats(Database:string;Options:TIBStatOptions;TableNames:String = ''): boolean;
     //Database server version
@@ -183,11 +189,15 @@ type
     //Event handler for Service output messages
     //Used in Backup and Restore operations and GetLog
     property OnOutput: TIBOnOutput read FOnOutput write FOnOutput;
+    // Interval (in milliseconds) to sleep while waiting for the service operation to end.
+    Property WaitInterval : Integer Read FWaitInterval Write FWaitInterval;
   end;
 
 
 implementation
 
+uses dateutils;
+
 resourcestring
   SErrNotConnected = '%s : %s : Not connected.';
   SErrError = '%s : %s : %s';
@@ -383,6 +393,7 @@ end;
 destructor TFBAdmin.Destroy;
 begin
   if FSvcHandle<>FB_API_NULLHANDLE then
+  WaitInterval:=100;
     DisConnect;
   FOutput.Destroy;
   inherited Destroy;
@@ -454,7 +465,9 @@ begin
     exit;
     end;
   if IBBkpVerbose in Options then
-    result:=GetOutput('Backup');
+    result:=GetOutput('Backup')
+  else if (IBBkpWait in Options) then
+    WaitForServiceCompletion(0);
 end;
 
 function TFBAdmin.BackupMultiFile(Database: string; Filenames: TStrings;
@@ -483,9 +496,52 @@ begin
     exit;
     end;
   if IBBkpVerbose in Options then
-    result:=GetOutput('BackupMultiFile');
+    result:=GetOutput('BackupMultiFile')
+  else if (IBBkpWait in Options) then
+    WaitForServiceCompletion(0);
 end;
 
+Function TFBAdmin.ServiceRunning : Boolean;
+
+const
+  BUFFERSIZE=1000;
+
+var
+  res:integer;
+  buffer: string;
+  spb:string;
+
+begin
+  FOutput.Clear;
+  spb:=chr(isc_info_svc_running);
+  setlength(buffer,BUFFERSIZE);
+  result:=isc_service_query(@FStatus[0], @FSvcHandle, nil, 0, nil, length(spb),
+          @spb[1],BUFFERSIZE,@buffer[1])=0;
+  if Not Result then
+    CheckError('ServiceRunning',FSTatus);
+  if (Buffer[1]=Char(isc_info_svc_running)) then
+    begin
+    res:=isc_vax_integer(@Buffer[2],4);
+    Result:=res=1;
+    end
+  else
+    IBRaiseError(0,'%s: Service status detection returned wrong result',[self.Name]);
+end;
+
+Function TFBAdmin.WaitForServiceCompletion(aTimeOut : Integer) : Boolean;
+
+Var
+  N : TDateTime;
+
+begin
+  N:=Now;
+  Repeat
+    Sleep(WaitInterval);
+    Result:=not ServiceRunning;
+  until Result or ((aTimeOut<>0) and (MilliSecondsBetween(Now,N)>aTimeOut*WaitInterval));
+end;
+
+
 function TFBAdmin.Restore(Database, Filename: string;
   Options: TIBRestoreOptions; RoleName: string): boolean;
 var
@@ -524,7 +580,9 @@ begin
     exit;
     end;
   if IBResVerbose in Options then
-    result:=GetOutput('Restore');
+    result:=GetOutput('Restore')
+  else if IBResWait in Options then
+    WaitForServiceCompletion(0);
 end;
 
 

packages/fcl-db/src/sqldb/interbase/fbeventmonitor.pp

@@ -27,7 +27,7 @@ unit FBEventMonitor;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 {$mode objfpc}{$H+}

packages/fcl-db/src/sqldb/mysql/mysqlconn.inc

@@ -154,8 +154,10 @@ Type
     function RefreshLastInsertID(Query : TCustomSQLQuery; Field : TField): Boolean; override;
   Public
     constructor Create(AOwner : TComponent); override;
+{$IFNDEF MYSQL50_UP}
     procedure GetFieldNames(const TableName : string; List :  TStrings); override;
     procedure GetTableNames(List : TStrings; SystemTables : Boolean = false); override;
+{$ENDIF}
     function GetConnectionInfo(InfoType:TConnInfoType): string; override;
     Function GetInsertID: int64;
     procedure CreateDB; override;
@@ -1199,6 +1201,7 @@ begin
   FMySQL := Nil;
 end;
 
+{$IFNDEF MYSQL50_UP}
 procedure TConnectionName.GetFieldNames(const TableName: string; List: TStrings);
 begin
   GetDBInfo(stColumns,TableName,'field',List);
@@ -1208,6 +1211,7 @@ procedure TConnectionName.GetTableNames(List: TStrings; SystemTables: Boolean);
 begin
   GetDBInfo(stTables,'','tables_in_'+DatabaseName,List)
 end;
+{$ENDIF}
 
 function TConnectionName.GetConnectionInfo(InfoType: TConnInfoType): string;
 begin
@@ -1294,13 +1298,19 @@ function TConnectionName.GetSchemaInfoSQL(SchemaType: TSchemaType;
 
 begin
   case SchemaType of
+    {$IFDEF MYSQL50_UP}
+    stTables     : result := 'SELECT * FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_SCHEMA=SCHEMA() AND TABLE_TYPE IN (''BASE TABLE'',''VIEW'')';
+    stColumns    : result := 'SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_SCHEMA=SCHEMA() AND TABLE_NAME='+QuotedStr(SchemaObjectName);
+    {$ELSE}
     stTables     : result := 'show tables';
     stColumns    : result := 'show columns from ' + EscapeString(SchemaObjectName);
+    {$ENDIF}
   else
-    DatabaseError(SMetadataUnavailable)
+                   result := inherited;
   end; {case}
 end;
 
+
 { TMySQLConnectionDef }
 
 class function TMySQLConnectionDef.TypeName: String;

packages/fcl-db/src/sqldb/odbc/odbcconn.pas

@@ -298,7 +298,7 @@ end;
 constructor TODBCConnection.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
-  FConnOptions := FConnOptions + [sqEscapeRepeat] + [sqEscapeSlash];
+  FConnOptions := FConnOptions + [sqSupportEmptyDatabaseName, sqEscapeRepeat, sqEscapeSlash];
 end;
 
 function TODBCConnection.StrToStatementType(s : string) : TStatementType;

packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp

@@ -27,7 +27,7 @@ unit PQEventMonitor;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 {$mode objfpc}{$H+}

packages/fcl-db/src/sqldb/sqldb.pp

@@ -290,7 +290,7 @@ type
     property HostName : string Read FHostName Write FHostName;
     Property OnLog : TDBLogNotifyEvent Read FOnLog Write FOnLog;
     Property LogEvents : TDBEventTypes Read FLogEvents Write FLogEvents Default LogAllEvents;
-    Property Options : TSQLConnectionOptions Read FOptions Write SetOptions;
+    Property Options : TSQLConnectionOptions Read FOptions Write SetOptions default [];
     Property Role :  String read FRole write FRole;
     property Connected;
     property DatabaseName;
@@ -340,7 +340,7 @@ type
     property Action : TCommitRollbackAction read FAction write FAction Default caRollBack;
     property Database;
     property Params : TStringList read FParams write SetParams;
-    Property Options : TSQLTransactionOptions Read FOptions Write SetOptions;
+    Property Options : TSQLTransactionOptions Read FOptions Write SetOptions default [];
   end;
 
 
@@ -578,6 +578,8 @@ type
     property AfterCancel;
     property BeforeDelete;
     property AfterDelete;
+    property BeforeRefresh;
+    property AfterRefresh;
     property BeforeScroll;
     property AfterScroll;
     property OnCalcFields;
@@ -596,7 +598,7 @@ type
     property UpdateSQL : TStringList read FUpdateSQL write SetUpdateSQL;
     property DeleteSQL : TStringList read FDeleteSQL write SetDeleteSQL;
     property RefreshSQL : TStringList read FRefreshSQL write SetRefreshSQL;
-    Property Options : TSQLQueryOptions Read FOptions Write SetOptions;
+    Property Options : TSQLQueryOptions Read FOptions Write SetOptions default [];
     property Params : TParams read GetParams Write SetParams;
     Property ParamCheck : Boolean Read GetParamCheck Write SetParamCheck default true;
     property ParseSQL : Boolean read GetParseSQL write SetParseSQL default true;
@@ -630,6 +632,7 @@ type
     Property AfterInsert;
     Property AfterOpen;
     Property AfterPost;
+    Property AfterRefresh;
     Property AfterScroll;
     Property BeforeCancel;
     Property BeforeClose;
@@ -638,6 +641,7 @@ type
     Property BeforeInsert;
     Property BeforeOpen;
     Property BeforePost;
+    Property BeforeRefresh;
     Property BeforeScroll;
     Property OnCalcFields;
     Property OnDeleteError;
@@ -1670,7 +1674,7 @@ Var
   P : TParam;
 
 begin
-  if not LogEvent(detParamValue) then
+  if not LogEvent(detParamValue) or not Assigned(AParams) then
     Exit;
   For P in AParams do
     begin
@@ -1857,7 +1861,7 @@ Var
   Where : String;
 
 begin
-  Result:=Query.RefreshSQL.Text;
+  Result:=Trim(Query.RefreshSQL.Text);
   if (Result='') then
     begin
     Where:='';
@@ -1908,7 +1912,7 @@ var
 
 begin
   qry:=Nil;
-  ReturningClause:=(sqSupportReturning in ConnOptions) and not (sqoRefreshUsingSelect in Query.Options) and (Query.RefreshSQL.Count=0);
+  ReturningClause:=(sqSupportReturning in ConnOptions) and not (sqoRefreshUsingSelect in Query.Options) and (Trim(Query.RefreshSQL.Text)='');
   case UpdateKind of
     ukInsert : begin
                s := Trim(Query.FInsertSQL.Text);
@@ -1984,6 +1988,8 @@ function TSQLConnection.GetSchemaInfoSQL( SchemaType : TSchemaType; SchemaObject
 
 begin
   case SchemaType of
+    stTables    : Result := 'SELECT * FROM INFORMATION_SCHEMA.TABLES WHERE TABLE_TYPE=''BASE TABLE''';
+    stColumns   : Result := 'SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE TABLE_NAME='+QuotedStr(SchemaObjectName);
     stProcedures: Result := 'SELECT *, ROUTINE_NAME AS PROCEDURE_NAME FROM INFORMATION_SCHEMA.ROUTINES';
     stSchemata  : Result := 'SELECT * FROM INFORMATION_SCHEMA.SCHEMATA';
     stSequences : Result := 'SELECT * FROM INFORMATION_SCHEMA.SEQUENCES';
@@ -2491,7 +2497,7 @@ Var
   DoReturning : Boolean;
 
 begin
-  Result:=(FRefreshSQL.Count<>0);
+  Result:=(Trim(FRefreshSQL.Text)<>'');
   DoReturning:=(sqSupportReturning in SQLConnection.ConnOptions) and not (sqoRefreshUsingSelect in Options);
   if Not (Result or DoReturning) then
     begin

packages/fcl-db/src/sqldb/sqlite/sqlite3backup.pas

@@ -27,7 +27,7 @@ unit sqlite3backup;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {$mode objfpc}{$H+}
 

packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp

@@ -409,13 +409,14 @@ Const
 
 procedure TSQLite3Connection.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TFieldDefs);
 var
- i, fi : integer;
- FN, FD, PrimaryKeyFields : string;
- ft1   : TFieldType;
+ st : psqlite3_stmt;
+ i, j, NotNull : integer;
+ FN, FD, PrimaryKeyFields : AnsiString;
+ FT : TFieldType;
  size1, size2 : integer;
- st    : psqlite3_stmt;
+ CN: PAnsiChar;
 
- function GetPrimaryKeyFields: string;
+ function GetPrimaryKeyFields: AnsiString;
  var IndexDefs: TServerIndexDefs;
      i: integer;
  begin
@@ -432,7 +433,7 @@ var
    Result := '';
  end;
 
- function ExtractPrecisionAndScale(decltype: string; var precision, scale: integer): boolean;
+ function ExtractPrecisionAndScale(decltype: AnsiString; var precision, scale: integer): boolean;
  var p: integer;
  begin
    p:=pos('(', decltype);
@@ -459,34 +460,34 @@ var
 begin
   PrimaryKeyFields := GetPrimaryKeyFields;
   st:=TSQLite3Cursor(cursor).fstatement;
-  for i:= 0 to sqlite3_column_count(st) - 1 do 
+  for i := 0 to sqlite3_column_count(st) - 1 do
     begin
-    FN:=sqlite3_column_name(st,i);
-    FD:=uppercase(sqlite3_column_decltype(st,i));
-    ft1:= ftUnknown;
-    size1:= 0;
-    for fi := 1 to FieldMapCount do if pos(FieldMap[fi].N,FD)=1 then
+    FN := sqlite3_column_name(st,i);
+    FD := uppercase(sqlite3_column_decltype(st,i));
+    FT := ftUnknown;
+    for j := 1 to FieldMapCount do if pos(FieldMap[j].N,FD)=1 then
       begin
-      ft1:=FieldMap[fi].t;
+      FT:=FieldMap[j].t;
       break;
       end;
     // Column declared as INTEGER PRIMARY KEY [AUTOINCREMENT] becomes ROWID for given table
     // declared data type must be INTEGER (not INT, BIGINT, NUMERIC etc.)
     if (FD='INTEGER') and SameText(FN, PrimaryKeyFields) then
-      ft1:=ftAutoInc;
+      FT:=ftAutoInc;
     // In case of an empty fieldtype (FD='', which is allowed and used in calculated
     // columns (aggregates) and by pragma-statements) or an unknown fieldtype,
     // use the field's affinity:
-    if ft1=ftUnknown then
+    if FT=ftUnknown then
       case TStorageType(sqlite3_column_type(st,i)) of
-        stInteger: ft1:=ftLargeInt;
-        stFloat:   ft1:=ftFloat;
-        stBlob:    ft1:=ftBlob;
-        else       ft1:=ftString;
+        stInteger: FT:=ftLargeInt;
+        stFloat:   FT:=ftFloat;
+        stBlob:    FT:=ftBlob;
+        else       FT:=ftString;
       end;
     // handle some specials.
     size1:=0;
-    case ft1 of
+    size2:=0;
+    case FT of
       ftString,
       ftFixedChar,
       ftFixedWideChar,
@@ -504,13 +505,22 @@ begin
                  size1 := 0;               //sql: if a scale is omitted then scale is 0
                  ExtractPrecisionAndScale(FD, size2, size1);
                  if (size2<=18) and (size1=0) then
-                   ft1:=ftLargeInt
+                   FT:=ftLargeInt
                  else if (size2-size1>MaxBCDPrecision-MaxBCDScale) or (size1>MaxBCDScale) then
-                   ft1:=ftFmtBCD;
+                   FT:=ftFmtBCD;
                end;
       ftUnknown : DatabaseErrorFmt('Unknown or unsupported data type %s of column %s', [FD, FN]);
     end; // Case
-    FieldDefs.Add(FieldDefs.MakeNameUnique(FN),ft1,size1,false,i+1);
+    // check if SQLite is compiled with SQLITE_ENABLE_COLUMN_METADATA
+    if Assigned(sqlite3_column_origin_name) then
+      CN := sqlite3_column_origin_name(st,i)
+    else
+      CN := nil;
+    // check only for physical table columns (not computed)
+    // is column declared as NOT NULL ? (table name parameter (3rd) must be not nil)
+    if not (Assigned(CN) and (sqlite3_table_column_metadata(fhandle, sqlite3_column_database_name(st,i), sqlite3_column_table_name(st,i), CN, nil, nil, @NotNull, nil, nil) = SQLITE_OK)) then
+      NotNull := 0;
+    FieldDefs.Add(FieldDefs.MakeNameUnique(FN), FT, size1, NotNull=1, i+1);
     end;
 end;
 
@@ -885,8 +895,8 @@ end;
 procedure TSQLite3Connection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
 var
   artableinfo, arindexlist, arindexinfo: TArrayStringArray;
-  il,ii: integer;
-  IndexName: string;
+  i,il,ii: integer;
+  DbName, IndexName: string;
   IndexOptions: TIndexOptions;
   PKFields, IXFields: TStrings;
 
@@ -907,14 +917,27 @@ begin
   IXFields:=TStringList.Create;
   IXFields.Delimiter:=';';
 
+  //check for multipart unquoted identifier: DatabaseName.TableName
+  if Pos('"',TableName) = 0 then
+    i := Pos('.',TableName)
+  else
+    i := 0;
+  if i>0 then
+    begin
+    DbName := Copy(TableName,1,i);
+    Delete(TableName,1,i);
+    end
+  else
+    DbName := '';
+
   //primary key fields; 5th column "pk" is zero for columns that are not part of PK
-  artableinfo := stringsquery('PRAGMA table_info('+TableName+');');
+  artableinfo := stringsquery('PRAGMA '+DbName+'table_info('+TableName+');');
   for ii:=low(artableinfo) to high(artableinfo) do
     if (high(artableinfo[ii]) >= 5) and (artableinfo[ii][5] >= '1') then
       PKFields.Add(artableinfo[ii][1]);
 
   //list of all table indexes
-  arindexlist:=stringsquery('PRAGMA index_list('+TableName+');');
+  arindexlist:=stringsquery('PRAGMA '+DbName+'index_list('+TableName+');');
   for il:=low(arindexlist) to high(arindexlist) do
     begin
     IndexName:=arindexlist[il][1];

packages/fcl-db/src/sqlite/customsqliteds.pas

@@ -28,7 +28,7 @@ unit CustomSqliteDS;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 {$Mode ObjFpc}

packages/fcl-db/src/sqlite/sqlite3ds.pas

@@ -28,7 +28,7 @@ unit Sqlite3DS;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 {$mode objfpc}

packages/fcl-db/src/sqlite/sqliteds.pas

@@ -28,7 +28,7 @@ unit SqliteDS;
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 
 {$mode objfpc}

packages/fcl-db/tests/sqldbtoolsunit.pas

@@ -196,6 +196,7 @@ begin
     UserName := dbuser;
     Password := dbpassword;
     HostName := dbhostname;
+    CharSet := dbcharset;
     if dblogfilename<>'' then
     begin
       LogEvents:=[detCustom,detCommit,detExecute,detRollBack];
@@ -357,6 +358,11 @@ begin
       testStringValues[i] := TrimRight(testStringValues[i]);
     end;
 
+  if SQLServerType in [ssMSSQL, ssSQLite, ssSybase] then
+    // Some DB's do not support sql compliant boolean data type.
+    for i := 0 to testValuesCount-1 do
+      testValues[ftBoolean, i] := BoolToStr(testBooleanValues[i], '1', '0');
+
   if SQLServerType in [ssMySQL] then
     begin
     // Some DB's do not support milliseconds in datetime and time fields.
@@ -498,46 +504,35 @@ begin
           begin
           sql := sql + ',F' + Fieldtypenames[FType];
           if testValues[FType,CountID] <> '' then
-            case FType of
-              ftBlob, ftBytes, ftGraphic, ftVarBytes:
-                if SQLServerType in [ssOracle] then
-                  // Oracle does not accept string literals in blob insert statements
-                  // convert 'DEADBEEF' hex literal to binary:
-                    sql1 := sql1 + ', HEXTORAW(' + QuotedStr(String2Hex(testValues[FType,CountID])) + ') '
-                  else // other dbs have no problems with the original string values
-                    sql1 := sql1 + ',' + QuotedStr(testValues[FType,CountID]);
-              ftCurrency:
-                sql1 := sql1 + ',' + testValues[FType,CountID];
-              ftDate:
-                // Oracle requires date conversion; otherwise
-                // ORA-01861: literal does not match format string
-                if SQLServerType in [ssOracle] then
-                  // ANSI/ISO date literal:
-                  sql1 := sql1 + ', DATE ' + QuotedStr(testValues[FType,CountID])
-                else
-                  sql1 := sql1 + ',' + QuotedStr(testValues[FType,CountID]);
-              ftDateTime:
-                // similar to ftDate handling
-                if SQLServerType in [ssOracle] then
-                begin
-                  // Could be a real date+time or only date. Does not consider only time.
-                  if pos(' ',testValues[FType,CountID])>0 then
-                    sql1 := sql1 + ', TIMESTAMP ' + QuotedStr(testValues[FType,CountID])
-                  else
-                    sql1 := sql1 + ', DATE ' + QuotedStr(testValues[FType,CountID]);
-                end
-                else
-                  sql1 := sql1 + ',' + QuotedStr(testValues[FType,CountID]);
-              ftTime:
-                // similar to ftDate handling
-                if SQLServerType in [ssOracle] then
-                  // More or less arbitrary default time; there is no time-only data type in Oracle.
-                  sql1 := sql1 + ', TIMESTAMP ' + QuotedStr('0001-01-01 '+testValues[FType,CountID])
-                else
-                  sql1 := sql1 + ',' + QuotedStr(testValues[FType,CountID]);
-              else
-                sql1 := sql1 + ',' + QuotedStr(testValues[FType,CountID])
+            if FType in [ftBoolean, ftCurrency] then
+               sql1 := sql1 + ',' + testValues[FType,CountID]
+            else if (FType in [ftBlob, ftBytes, ftGraphic, ftVarBytes]) and
+                    (SQLServerType = ssOracle) then
+               // Oracle does not accept string literals in blob insert statements
+               // convert 'DEADBEEF' hex literal to binary:
+               sql1 := sql1 + ', HEXTORAW(' + QuotedStr(String2Hex(testValues[FType,CountID])) + ') '
+            else if (FType = ftDate) and
+                    (SQLServerType = ssOracle) then
+               // Oracle requires date conversion; otherwise
+               // ORA-01861: literal does not match format string
+               // ANSI/ISO date literal:
+               sql1 := sql1 + ', DATE ' + QuotedStr(testValues[FType,CountID])
+            else if (FType = ftDateTime) and
+                    (SQLServerType = ssOracle) then begin
+               // similar to ftDate handling
+               // Could be a real date+time or only date. Does not consider only time.
+               if pos(' ',testValues[FType,CountID])>0 then
+                  sql1 := sql1 + ', TIMESTAMP ' + QuotedStr(testValues[FType,CountID])
+               else
+                  sql1 := sql1 + ', DATE ' + QuotedStr(testValues[FType,CountID]);
             end
+            else if (FType = ftTime) and
+                    (SQLServerType = ssOracle) then
+               // similar to ftDate handling
+               // More or less arbitrary default time; there is no time-only data type in Oracle.
+               sql1 := sql1 + ', TIMESTAMP ' + QuotedStr('0001-01-01 '+testValues[FType,CountID])
+            else
+               sql1 := sql1 + ',' + QuotedStr(testValues[FType,CountID])
           else
             sql1 := sql1 + ',NULL';
           end;

packages/fcl-db/tests/testdbbasics.pas

@@ -88,6 +88,7 @@ type
     procedure TestMultipleDeleteUpdateBuffer;
     procedure TestDoubleDelete;
     procedure TestMergeChangeLog;
+    procedure TestRevertRecord;
   // index tests
     procedure TestAddIndexInteger;
     procedure TestAddIndexSmallInt;
@@ -167,6 +168,7 @@ type
     procedure TestBug6893;
     procedure TestRequired;
     procedure TestModified;
+    procedure TestUpdateCursorPos;         // bug 31532
     // fields
     procedure TestFieldOldValueObsolete;
     procedure TestFieldOldValue;
@@ -683,6 +685,37 @@ begin
   end;
 end;
 
+procedure TTestCursorDBBasics.TestUpdateCursorPos;
+var
+  datasource1: TDataSource;
+  datalink1: TDataLink;
+  dataset1: TDataSet;
+  i,r: integer;
+begin
+  // TBufDataset should notify TDataset (TDataset.CurrentRecord) when changes internaly current record
+  // TBufDataset.GetRecNo was synchronizing its internal position with TDataset.ActiveRecord, but TDataset.CurrentRecord remains unchaged
+  // Bug #31532
+  dataset1 := DBConnector.GetNDataset(16);
+  datasource1 := TDataSource.Create(nil);
+  datasource1.DataSet := dataset1;
+  datalink1 := TDataLink.Create;
+  datalink1:= TDataLink.create;
+  datalink1.DataSource:= datasource1;
+  datalink1.BufferCount:= 12;
+
+  dataset1.Open;
+  dataset1.MoveBy(4);
+  CheckEquals(5, dataset1.RecNo);
+  for i:=13 to 15 do begin
+    datalink1.BufferCount := datalink1.BufferCount+1;
+    r := dataset1.RecNo; // syncronizes source dataset to ActiveRecord
+    datalink1.ActiveRecord := datalink1.BufferCount-1;
+    CheckEquals(i, dataset1.FieldByName('ID').AsInteger);
+  end;
+  datasource1.free;
+  datalink1.free;
+end;
+
 procedure TTestDBBasics.TestDetectionNonMatchingDataset;
 var
   F: TField;
@@ -1231,6 +1264,7 @@ begin
     begin
     Open;
 
+    // modify records
     for i := 0 to 16 do
       begin
       if i mod 4=0 then
@@ -1242,19 +1276,21 @@ begin
       next;
       end;
 
-    for i := 17 to 20 do
+    // append new records
+    for i := 18 to 21 do
       begin
       append;
-      fieldbyname('id').AsInteger:=i+1;
-      fieldbyname('name').AsString:='TestName'+inttostr(i+1);
+      fieldbyname('id').AsInteger:=i;
+      fieldbyname('name').AsString:='TestName'+inttostr(i);
       post;
       end;
 
+    // delete records #1,5,9,13,17,21 which was modified or appended before
     first;
     for i := 0 to 20 do if i mod 4=0 then
       delete
     else
-       next;
+      next;
 
     First;
     i := 0;
@@ -1279,10 +1315,10 @@ begin
       CancelUpdates;
 
       First;
-      for i := 0 to 16 do
+      for i := 1 to 17 do
         begin
-        CheckEquals(i+1,FieldByName('ID').AsInteger);
-        CheckEquals('TestName'+inttostr(i+1),FieldByName('NAME').AsString);
+        CheckEquals(i, FieldByName('ID').AsInteger);
+        CheckEquals('TestName'+inttostr(i), FieldByName('NAME').AsString);
         next;
         end;
 
@@ -1785,6 +1821,77 @@ begin
     end;
 end;
 
+procedure TTestBufDatasetDBBasics.TestRevertRecord;
+begin
+  with DBConnector.GetNDataset(True,1) as TCustomBufDataset do
+  begin
+    Open;
+    // update value in one record and revert them
+    Edit;
+    FieldByName('ID').AsInteger := 100;
+    Post;
+    CheckEquals(100, FieldByName('ID').AsInteger);
+    RevertRecord;
+    CheckEquals(1, FieldByName('ID').AsInteger, 'Revert modified #1');
+    // append new record and delete prior and revert appended
+    AppendRecord([3,'']);
+    InsertRecord([2,'']);
+    Prior;
+    Delete; // 1st
+    Next;
+    RevertRecord; // 3rd
+    CheckEquals(2, FieldByName('ID').AsInteger, 'Revert inserted #1a');
+    RevertRecord; // 2nd
+    CheckTrue(Eof, 'Revert inserted #1b');
+    CancelUpdates; // restores 1st deleted record
+    CheckEquals(1, FieldByName('ID').AsInteger, 'CancelUpdates #1');
+    Close;
+  end;
+
+  with DBConnector.GetNDataset(False,0) as TCustomBufDataset do
+  begin
+    Open;
+    // insert one record and revert them
+    InsertRecord([1,'']);
+    RevertRecord;
+    CheckTrue(Eof);
+    CheckEquals(0, ChangeCount);
+
+    // insert two records and revert them in inverse order
+    AppendRecord([2,'']);
+    InsertRecord([1,'']); // this record in update-buffer is linked to 2
+    RevertRecord;
+    CheckEquals(2, FieldByName('ID').AsInteger);
+    CheckEquals(1, ChangeCount);
+    RevertRecord;
+    CheckTrue(Eof);
+    CheckEquals(0, ChangeCount);
+
+    // insert more records and some delete and some revert
+    AppendRecord([4,'']);
+    InsertRecord([3,'']);
+    InsertRecord([2,'']);
+    InsertRecord([1,'']);
+    CheckEquals(4, ChangeCount);
+    Delete;  // 1
+    CheckEquals(4, ChangeCount);
+    Next;    // 3
+    RevertRecord;
+    CheckEquals(4, FieldByName('ID').AsInteger);
+    CheckEquals(3, ChangeCount);
+    Prior;   // 2
+    RevertRecord;
+    CheckEquals(4, FieldByName('ID').AsInteger);
+    CheckEquals(2, ChangeCount);
+
+    CancelUpdates;
+    CheckTrue(Eof);
+    CheckEquals(0, ChangeCount);
+
+    Close;
+  end;
+end;
+
 procedure TTestBufDatasetDBBasics.FTestXMLDatasetDefinition(ADataset: TDataset);
 var i : integer;
 begin

packages/fcl-db/tests/testfieldtypes.pas

@@ -2181,12 +2181,12 @@ end;
 
 procedure TTestFieldTypes.TestTableNames;
 var TableList : TStringList;
-    i         : integer;
+
 begin
   TableList := TStringList.Create;
   try
     TSQLDBConnector(DBConnector).Connection.GetTableNames(TableList);
-    AssertTrue(TableList.Find('fpdev',i));
+    AssertTrue(TableList.IndexOf('fpdev')<>-1);
   finally
     TableList.Free;
   end;
@@ -2216,7 +2216,7 @@ begin
   FieldList := TStringList.Create;
   try
     TSQLDBConnector(DBConnector).Connection.GetFieldNames('fpdev',FieldList);
-    AssertTrue(FieldList.Find('id',i));
+    AssertTrue(FieldList.IndexOf('id')<>-1);
   finally
     FieldList.Free;
   end;

packages/fcl-db/tests/testspecifictbufdataset.pas

@@ -195,9 +195,11 @@ begin
   try
     F := TIntegerField.Create(ds);
     F.FieldName:='ID';
+    F.Required:=True;
     F.DataSet:=ds;
     F := TStringField.Create(ds);
     F.FieldName:='NAME';
+    F.Required:=False;
     F.DataSet:=ds;
     F.Size:=50;
 
@@ -221,6 +223,8 @@ begin
 
     TestDataset(ds);
 
+    CheckTrue(ds.FieldDefs[0].Required, 'Required');
+    CheckFalse(ds.FieldDefs[1].Required, 'not Required');
     for i := 0 to ds.FieldDefs.Count-1 do
       begin
       CheckNotEquals(ds.FieldDefs[i].Name,'NAME_CALC');

packages/fcl-db/tests/toolsunit.pas

@@ -224,6 +224,7 @@ var dbtype,
     dbuser,
     dbhostname,
     dbpassword,
+    dbcharset,
     dblogfilename,
     dbQuoteChars   : string;
     dblogfile      : TextFile;
@@ -476,17 +477,18 @@ procedure ReadIniFile;
 var IniFile : TIniFile;
 
 begin
-  IniFile := TIniFile.Create(getcurrentdir + PathDelim + 'database.ini');
+  IniFile := TIniFile.Create(GetCurrentDir + PathDelim + 'database.ini');
   dbtype:='';
-  if Paramcount>0 then
+  if ParamCount>0 then
     dbtype := ParamStr(1);
-  if (dbtype='') or not inifile.SectionExists(dbtype) then
+  if (dbtype='') or not IniFile.SectionExists(dbtype) then
     dbtype := IniFile.ReadString('Database','Type','');
   dbconnectorname := IniFile.ReadString(dbtype,'Connector','');
   dbname := IniFile.ReadString(dbtype,'Name','');
   dbuser := IniFile.ReadString(dbtype,'User','');
   dbhostname := IniFile.ReadString(dbtype,'Hostname','');
   dbpassword := IniFile.ReadString(dbtype,'Password','');
+  dbcharset := IniFile.ReadString(dbtype,'CharSet','');
   dbconnectorparams := IniFile.ReadString(dbtype,'ConnectorParams','');
   dblogfilename := IniFile.ReadString(dbtype,'LogFile','');
   dbquotechars := IniFile.ReadString(dbtype,'QuoteChars','"');
@@ -526,8 +528,6 @@ end;
 
 procedure InitialiseDBConnector;
 
-const B: array[boolean] of char=('0','1');  // should be exported from some main db unit, as SQL true/false?
-
 var DBConnectorClass : TPersistentClass;
     i                : integer;
     FormatSettings   : TFormatSettings;
@@ -548,7 +548,7 @@ begin
   testValues[ftFMTBcd] := testFmtBCDValues;
   for i := 0 to testValuesCount-1 do
     begin
-    testValues[ftBoolean,i] := B[testBooleanValues[i]];
+    testValues[ftBoolean,i] := BoolToStr(testBooleanValues[i], True);
     testValues[ftFloat,i] := FloatToStr(testFloatValues[i],FormatSettings);
     testValues[ftSmallint,i] := IntToStr(testSmallIntValues[i]);
     testValues[ftInteger,i] := IntToStr(testIntValues[i]);

packages/fcl-fpcunit/src/fpcunit.pp

@@ -618,13 +618,13 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: string);
 begin
-  AssertTrue(ComparisonMsg(AMessage ,Expected, Actual), AnsiCompareStr(Expected, Actual) = 0,CallerAddr);
+  AssertTrue(ComparisonMsg(AMessage ,Expected, Actual), Expected=Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: string);
 begin
-  AssertTrue(ComparisonMsg(Expected, Actual), AnsiCompareStr(Expected, Actual) = 0,CallerAddr);
+  AssertTrue(ComparisonMsg(Expected, Actual), Expected=Actual,CallerAddr);
 end;
 
 {$IFDEF UNICODE}

packages/fcl-image/examples/drawing.pp

@@ -1,19 +1,19 @@
 {$mode objfpc}{$h+}
 program Drawing;
 
-uses classes, sysutils,
-     FPImage, FPCanvas, FPImgCanv, ftFont,
-     FPWritePNG, FPReadPNG;
+uses cwstring,classes, sysutils, FPImage, FPCanvas, FPImgCanv, FPWritePNG, FPReadPNG;
 
 const
   MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
 
 procedure DoDraw;
-var canvas : TFPcustomCAnvas;
-    ci, image : TFPCustomImage;
-    writer : TFPCustomImageWriter;
-    reader : TFPCustomImageReader;
-    f : TFreeTypeFont;
+
+var
+  canvas : TFPcustomCAnvas;
+  ci,image : TFPCustomImage;
+  writer : TFPCustomImageWriter;
+  reader : TFPCustomImageReader;
+
 begin
   image := TFPMemoryImage.Create (100,100);
   ci := TFPMemoryImage.Create (20,20);
@@ -28,9 +28,11 @@ begin
     GrayScale := false;
     end;
   try
-//    ci.LoadFromFile ('test.png', reader);
+    ci.LoadFromFile ('pattern.png', reader);
     with Canvas as TFPImageCanvas do
       begin
+      brush.FPcolor:=colwhite;
+      brush.style:=bsSolid;
       pen.mode := pmCopy;
       pen.style := psSolid;
       pen.width := 1;
@@ -51,14 +53,14 @@ begin
         blue := green;
         end;
       pen.style := psSolid;
+
       RelativeBrushImage := true;
-{
       brush.image := ci;
       brush.style := bsimage;
       with brush.FPColor do
         green := green div 2;
       Ellipse (11,11, 89,89);
-}
+
 
       brush.style := bsSolid;
       brush.FPColor := MyColor;
@@ -71,31 +73,18 @@ begin
       pen.FPColor := colCyan;
       ellipseC (50,50, 1,1);
 
-      InitEngine;
-      F:=TFreeTypeFont.Create;
-      F.Angle:=0.15;
-      Font:=F;
-//      Font.Name:='/usr/share/fonts/truetype/ttf-dejavu/DejaVuSans.ttf';
-      Font.Name:='/home/michael/Documents/arial.ttf';
-      Font.Size:=10;
-      Font.FPColor:=colWhite;
-//      Font.Orientation:=900;
-      
-      Canvas.TextOut(10,90,'o');
       end;
-      writeln ('Saving to inspect !');
-    image.SaveToFile ('DrawTest.png', writer);
+      writeln ('Saving to "DrawTest.png" for inspection !');
+     image.SaveToFile ('DrawTest.png', writer);
   finally
     Canvas.Free;
+    ci.free;
     image.Free;
     writer.Free;
-    ci.free;
     reader.Free;
   end;
 end;
 
 begin
-//  DefaultFontPath := '/usr/share/fonts/truetype/ttf-dejavu/';
   DoDraw;
-
 end.

packages/fcl-image/examples/imgconv.pp

@@ -19,7 +19,7 @@ program ImgConv;
 
 uses FPWriteXPM, FPWritePNG, FPWriteBMP,
      FPReadXPM, FPReadPNG, FPReadBMP, fpreadjpeg,fpwritejpeg,
-     fpreadtga,fpwritetga,fpreadpnm,fpwritepnm,
+     fpreadtga,fpwritetga,fpreadpnm,fpwritepnm, fpreadtiff, fpwritetiff,
      {$ifndef UseFile}classes,{$endif}
      FPImage, sysutils;
 
@@ -44,6 +44,8 @@ begin
       Reader := TFPReaderPNG.Create
     else if T = 'T' then
       Reader := TFPReaderTarga.Create
+    else if T = 'F' then
+      Reader := TFPReaderTiff.Create
     else if T = 'N' then
       Reader := TFPReaderPNM.Create
     else
@@ -77,6 +79,8 @@ begin
     Writer := TFPWriterPNG.Create
   else if T = 'T' then
     Writer := TFPWriterTARGA.Create
+  else if T = 'F' then
+    Writer := TFPWriterTiff.Create
   else if T = 'N' then
     Writer := TFPWriterPNM.Create
   else
@@ -150,7 +154,7 @@ begin
     begin
     writeln ('Give filename to read and to write, preceded by filetype:');
     writeln ('X for XPM, P for PNG, B for BMP, J for JPEG, T for TGA,');
-    writeln ('N for PNM (read only)');
+    writeln ('N for PNM (read only), F for TIFF');
     writeln ('example: imgconv X hello.xpm P hello.png');
     writeln ('example: imgconv hello.xpm P hello.png');
     writeln ('Options for');

packages/fcl-image/examples/textout.pp

@@ -0,0 +1,116 @@
+{$mode objfpc}{$h+}
+{$CODEPAGE UTF8}
+program textout;
+
+uses
+  cwstring,classes, sysutils, FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, freetype;
+
+const
+  MyColor : TFPColor = (Red: $7FFF; Green: $0000; Blue: $FFFF; Alpha: alphaOpaque);
+
+procedure DoDraw(FN, fnChinese : String);
+
+var
+  canvas : TFPcustomCAnvas;
+  image : TFPCustomImage;
+  writer : TFPCustomImageWriter;
+  f : TFreeTypeFont;
+  S : String;
+  U : UnicodeString;
+
+begin
+  f:=Nil;
+  image := TFPMemoryImage.Create (256,256);
+  Canvas := TFPImageCanvas.Create (image);
+  Writer := TFPWriterPNG.Create;
+  InitEngine;
+  with TFPWriterPNG(Writer) do
+    begin
+    indexed := false;
+    wordsized := false;
+    UseAlpha := false;
+    GrayScale := false;
+    end;
+  try
+    with Canvas as TFPImageCanvas do
+      begin
+      // Clear background
+      brush.FPcolor:=colwhite;
+      brush.style:=bsSolid;
+      pen.mode := pmCopy;
+      pen.style := psSolid;
+      pen.width := 1;
+      pen.FPColor := colWhite;
+      FillRect(0,0,255,255);
+      // Set font
+      F:=TFreeTypeFont.Create;
+      Font:=F;
+      Font.Name:=FN;
+      Font.Size:=14;
+      Font.FPColor:=colBlack;
+      S:='Hello, world!';
+      Canvas.TextOut(20,20,S);
+      U:=UTF8Decode('привет, Мир!');
+      Font.FPColor:=colBlue;
+      Canvas.TextOut(50,50,U);
+      if (FNChinese<>'') then
+        begin
+        Font.Name:=FNChinese;
+        U:=UTF8Decode('你好，世界!');
+        Font.FPColor:=colRed;
+        Canvas.TextOut(20,100,U);
+        end
+      else
+        begin
+        Font.Size:=10;
+        Canvas.TextOut(20,100,'No chinese font available.');
+        end;
+      U:=UTF8Decode('non-ASCII chars: ßéùµàçè§âêû');
+      Font.Size:=10;
+      Canvas.TextOut(20,180,U);
+      end;
+    writeln ('Saving to "TextTest.png" for inspection !');
+    Image.SaveToFile ('TextTest.png', writer);
+  finally
+    F.Free;
+    Canvas.Free;
+    image.Free;
+    writer.Free;
+  end;
+end;
+
+Var
+  D,FontFile, FontFileChinese : String;
+  Info : TSearchRec;
+
+begin
+  // Initialize font search path;
+{$IFDEF UNIX}
+{$IFNDEF DARWIN}
+  D := '/usr/share/fonts/truetype/';
+  DefaultSearchPath:=D;
+  if FindFirst(DefaultSearchPath+AllFilesMask,faDirectory,Info)=0 then
+    try
+      repeat
+        if (Info.Attr and faDirectory)<>0 then
+          if (Info.Name<>'.') and (info.name<>'..') then
+            DefaultSearchPath:=DefaultSearchPath+';'+D+Info.Name;
+      Until FindNext(Info)<>0;
+    finally
+      FindClose(Info);
+    end;
+{$ENDIF}
+{$ENDIF}
+  FontFile:=ParamStr(1);
+  if FontFile='' then
+    FontFile:='LiberationSans-Regular.ttf';
+  FontFileChinese:=ParamStr(2);
+  if FontFileChinese='' then
+    With TFontManager.Create do
+      try
+          FontFileChinese:=SearchFont('wqy-microhei.ttc',False);
+      finally
+        Free;
+      end;
+  DoDraw(FontFile,FontFileChinese);
+end.

packages/fcl-image/src/fpcanvas.inc

@@ -353,6 +353,77 @@ begin
     result := DoGetTextWidth (Text);
 end;
 
+procedure TFPCustomCanvas.TextOut (x,y:integer;text:unicodestring);
+begin
+  if Font is TFPCustomDrawFont then
+    TFPCustomDrawFont(Font).DrawText(x,y, text)
+  else
+    DoTextOut (x,y, text);
+end;
+
+procedure TFPCustomCanvas.GetTextSize (text:unicodestring; var w,h:integer);
+begin
+  if Font is TFPCustomDrawFont then
+    TFPCustomDrawFont(Font).GetTextSize (text, w, h)
+  else
+    DoGetTextSize (Text, w, h);
+end;
+
+function TFPCustomCanvas.GetTextHeight (text:unicodestring) : integer;
+begin
+  Result := TextHeight(Text);
+end;
+
+function TFPCustomCanvas.GetTextWidth (text:unicodestring) : integer;
+begin
+  Result := TextWidth(Text);
+end;
+
+function TFPCustomCanvas.TextExtent(const Text: unicodestring): TSize;
+begin
+  GetTextSize(Text, Result.cx, Result.cy);
+end;
+
+function TFPCustomCanvas.TextHeight(const Text: unicodestring): Integer;
+begin
+  if Font is TFPCustomDrawFont then
+    result := TFPCustomDrawFont(Font).GetTextHeight (text)
+  else
+    result := DoGetTextHeight (Text);
+end;
+
+function TFPCustomCanvas.TextWidth(const Text: unicodestring): Integer;
+begin
+  if Font is TFPCustomDrawFont then
+    result := TFPCustomDrawFont(Font).GetTextWidth (text)
+  else
+    result := DoGetTextWidth (Text);
+end;
+
+procedure TFPCustomCanvas.DoTextOut (x,y:integer;text:unicodestring); 
+
+begin
+  DoTextOut(x,y,string(text));
+end;
+
+procedure TFPCustomCanvas.DoGetTextSize (text:unicodestring; var w,h:integer); 
+
+begin
+  DoGetTextSize(String(Text),w,h);
+end;
+
+function  TFPCustomCanvas.DoGetTextHeight (text:unicodestring) : integer; 
+
+begin
+  Result:=DoGetTextHeight(String(text));
+end;
+
+function  TFPCustomCanvas.DoGetTextWidth (text:unicodestring) : integer; 
+
+begin
+  Result:=DoGetTextWidth(String(text));
+end;
+
 procedure TFPCustomCanvas.Arc(ALeft, ATop, ARight, ABottom, Angle16Deg,
   Angle16DegLength: Integer);
 begin

packages/fcl-image/src/fpcanvas.pp

@@ -278,6 +278,10 @@ type
     procedure DoGetTextSize (text:string; var w,h:integer); virtual; abstract;
     function  DoGetTextHeight (text:string) : integer; virtual; abstract;
     function  DoGetTextWidth (text:string) : integer; virtual; abstract;
+    procedure DoTextOut (x,y:integer;text:unicodestring); virtual; 
+    procedure DoGetTextSize (text:unicodestring; var w,h:integer); virtual; 
+    function  DoGetTextHeight (text:unicodestring) : integer; virtual; 
+    function  DoGetTextWidth (text:unicodestring) : integer; virtual; 
     procedure DoRectangle (Const Bounds:TRect); virtual; abstract;
     procedure DoRectangleFill (Const Bounds:TRect); virtual; abstract;
     procedure DoRectangleAndFill (Const Bounds:TRect); virtual;
@@ -317,6 +321,13 @@ type
     function TextExtent(const Text: string): TSize; virtual;
     function TextHeight(const Text: string): Integer; virtual;
     function TextWidth(const Text: string): Integer; virtual;
+    procedure TextOut (x,y:integer;text:unicodestring); virtual;
+    procedure GetTextSize (text:unicodestring; var w,h:integer);
+    function GetTextHeight (text:unicodestring) : integer;
+    function GetTextWidth (text:unicodestring) : integer;
+    function TextExtent(const Text: unicodestring): TSize; virtual;
+    function TextHeight(const Text: unicodestring): Integer; virtual;
+    function TextWidth(const Text: unicodestring): Integer; virtual;
     // using pen and brush
     procedure Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); virtual;
     procedure Arc(ALeft, ATop, ARight, ABottom, SX, SY, EX, EY: Integer); virtual;
@@ -374,11 +385,19 @@ type
     procedure GetTextSize (text:string; var w,h:integer);
     function GetTextHeight (text:string) : integer;
     function GetTextWidth (text:string) : integer;
+    procedure DrawText (x,y:integer; text:unicodestring);
+    procedure GetTextSize (text: unicodestring; var w,h:integer);
+    function GetTextHeight (text: unicodestring) : integer;
+    function GetTextWidth (text: unicodestring) : integer;
   protected
     procedure DoDrawText (x,y:integer; text:string); virtual; abstract;
     procedure DoGetTextSize (text:string; var w,h:integer); virtual; abstract;
     function DoGetTextHeight (text:string) : integer; virtual; abstract;
     function DoGetTextWidth (text:string) : integer; virtual; abstract;
+    procedure DoDrawText (x,y:integer; text:unicodestring); virtual;
+    procedure DoGetTextSize (text: unicodestring; var w,h:integer); virtual; 
+    function DoGetTextHeight (text: unicodestring) : integer; virtual; 
+    function DoGetTextWidth (text: unicodestring) : integer; virtual; 
   end;
 
   TFPEmptyFont = class (TFPCustomFont)

packages/fcl-image/src/fpcdrawh.inc

@@ -77,3 +77,50 @@ function TFPCustomDrawFont.GetTextWidth (text:string) : integer;
 begin
   result := DoGetTextWidth (Text);
 end;
+
+procedure TFPCustomDrawFont.DrawText (x,y:integer; text:UnicodeString);
+begin
+  DoDrawText (x,y, text);
+end;
+
+procedure TFPCustomDrawFont.GetTextSize (text:UnicodeString; var w,h:integer);
+begin
+  DoGetTextSize (text, w,h);
+end;
+
+function TFPCustomDrawFont.GetTextHeight (text:UnicodeString) : integer;
+begin
+  result := DoGetTextHeight (Text);
+end;
+
+function TFPCustomDrawFont.GetTextWidth (text:UnicodeString) : integer;
+begin
+  result := DoGetTextWidth (Text);
+end;
+
+procedure TFPCustomDrawFont.DoDrawText (x,y:integer; text:unicodestring); 
+
+begin
+  DoDrawText(x,y,String(text));
+end;
+
+procedure TFPCustomDrawFont.DoGetTextSize (text: unicodestring; var w,h:integer); 
+
+begin
+  DoGetTextSize(String(text),w,h);
+end;
+
+
+
+function TFPCustomDrawFont.DoGetTextHeight (text: unicodestring) : integer;  
+
+begin
+  Result:=DoGetTextHeight(String(text));
+end;
+
+function TFPCustomDrawFont.DoGetTextWidth (text: unicodestring) : integer; 
+
+begin
+  Result:=DoGetTextWidth(String(text));
+end;
+

packages/fcl-image/src/fpimage.pp

@@ -314,7 +314,8 @@ type
     StrNoCorrectReaderFound,
     StrReadWithError,
     StrWriteWithError,
-    StrNoPaletteAvailable
+    StrNoPaletteAvailable,
+    StrInvalidHTMLColor
     );
 
 const
@@ -335,7 +336,8 @@ const
      'Can''t determine image type of stream',
      'Error while reading stream: %s',
      'Error while writing stream: %s',
-     'No palette available'
+     'No palette available',
+     'Invalid HTML color : %s'
      );
 
 {$i fpcolors.inc}
@@ -553,6 +555,11 @@ Pass FreeImg=true to call Img.Free }
 function GetMinimumFPCompactImg(Img: TFPCustomImage; FreeImg: boolean;
 FuzzyDepth: word = 4): TFPCustomImage;
 
+{ HTML Color support. RRGGBB or color name. Only W3 color names s are supported}
+
+function TryHtmlToFPColor(const S: String; out FPColor: TFPColor): Boolean;
+function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; Def: TFPColor): TFPColor;
+function HtmlToFpColor(const S: String): TFPColor;
 
 
 implementation
@@ -645,6 +652,121 @@ begin
 end;
 {$endif}
 
+type
+  THtmlColorName = (
+    hcnWhite, hcnSilver, hcnGray, hcnBlack,
+    hcnRed, hcnMaroon, hcnYellow, hcnOlive,
+    hcnLime, hcnGreen, hcnAqua, hcnTeal, hcnBlue,
+    hcnNavy, hcnFuchsia, hcnPurple);
+
+const
+  HtmlColorNameToFPColorMap: array[THtmlColorName] of TFPColor = (
+    (red: $ff; green: $ff; blue: $ff; alpha: alphaOpaque), //hcnWhite
+    (red: $c0; green: $c0; blue: $c0; alpha: alphaOpaque), //hcnSilver
+    (red: $80; green: $80; blue: $80; alpha: alphaOpaque), //hcnGray
+    (red: $00; green: $00; blue: $00; alpha: alphaOpaque), //hcnBlack
+    (red: $ff; green: $00; blue: $00; alpha: alphaOpaque), //hcnRed
+    (red: $80; green: $00; blue: $00; alpha: alphaOpaque), //hcnMaroon
+    (red: $ff; green: $ff; blue: $00; alpha: alphaOpaque), //hcnYellow
+    (red: $80; green: $80; blue: $00; alpha: alphaOpaque), //hcnOlive
+    (red: $00; green: $ff; blue: $00; alpha: alphaOpaque), //hcnLime
+    (red: $00; green: $80; blue: $00; alpha: alphaOpaque), //hcnGreen
+    (red: $00; green: $ff; blue: $ff; alpha: alphaOpaque), //hcnAqua
+    (red: $00; green: $80; blue: $80; alpha: alphaOpaque), //hcnTeal
+    (red: $00; green: $00; blue: $ff; alpha: alphaOpaque), //hcnBlue
+    (red: $00; green: $00; blue: $80; alpha: alphaOpaque), //hcnNavy
+    (red: $ff; green: $00; blue: $ff; alpha: alphaOpaque), //hcnFuchsia
+    (red: $80; green: $00; blue: $80; alpha: alphaOpaque)  //hcnPurple
+  );
+
+function TryStrToHtmlColorName(const S: String; out AName: THtmlColorName): Boolean;
+begin
+   Result := True;
+   case LowerCase(S) of
+     'white'  : AName := hcnWhite;
+     'silver' : AName := hcnSilver;
+     'gray'   : AName := hcnGray;
+     'black'  : AName := hcnBlack;
+     'red'    : AName := hcnRed;
+     'maroon' : AName := hcnMaroon;
+     'yellow' : AName := hcnYellow;
+     'olive'  : AName := hcnOlive;
+     'lime'   : AName := hcnLime;
+     'green'  : AName := hcnGreen;
+     'aqua'   : AName := hcnAqua;
+     'teal'   : AName := hcnTeal;
+     'blue'   : AName := hcnBlue;
+     'navy'   : AName := hcnNavy;
+     'fuchsia': AName := hcnFuchsia;
+     'purple' : AName := hcnPurple;
+  else
+    Result := False;
+  end;
+end;
+
+{ Try to translate HTML color code into TFPColor
+  Supports following formats
+    '#rgb'
+    '#rrggbb'
+    W3C Html color name
+}
+function TryHtmlToFPColor(const S: String; out FPColor: TFPColor): Boolean;
+
+  function TryHexStrToWord(const Hex: String; out W: Word): Boolean;
+  var
+    Code: Integer;
+  begin
+    Val('$'+Hex, W, Code);
+    Result := (Code = 0);
+    if not Result then W := 0;
+  end;
+
+var
+  AName: THtmlColorName;
+begin
+  Result := False;
+  FPColor.red := 0;
+  FPColor.green := 0;
+  FPColor.blue := 0;
+  FPColor.alpha := alphaOpaque;
+  if (Length(S) = 0) then
+    Exit;
+  if (S[1] = '#') then
+  begin
+    if Length(S) = 4 then
+    begin  // #rgb
+      Result := (TryHexstrToWord(S[2]+S[2], FPColor.red) and
+                 TryHexstrToWord(S[3]+S[3], FPColor.green) and
+                 TryHexstrToWord(S[4]+S[4], FPColor.blue));
+    end
+    else if Length(S) = 7 then
+    begin  // #rrggbb
+      Result := (TryHexstrToWord(S[2]+S[3], FPColor.red) and
+                 TryHexstrToWord(S[4]+S[5], FPColor.green) and
+                 TryHexstrToWord(S[6]+S[7], FPColor.blue));
+    end;
+  end
+  else
+  begin
+    Result := TryStrToHtmlColorName(S, AName);
+    if Result then
+      FPColor := HtmlColorNameToFPColorMap[AName];
+  end;
+end;
+
+function HtmlToFPColorDef(const S: String; out FPColor: TFpColor; Def: TFPColor): TFPColor;
+begin
+  if not TryHtmlToFPColor(S, Result) then
+    Result := Def;
+end;
+
+function HtmlToFpColor(const S: String): TFPColor;
+begin
+  if not TryHtmlToFpColor(S, Result) then
+    raise EConvertError.CreateFmt(ErrorText[StrInvalidHTMLColor], [S]);
+end;
+
+
 initialization
   ImageHandlers := TImageHandlersManager.Create;
   GrayConvMatrix := GCM_JPEG;

packages/fcl-image/src/fppixlcanv.pp

@@ -28,14 +28,18 @@ type
 
   PixelCanvasException = class (TFPCanvasException);
 
+  { TFPPixelCanvas }
+
   TFPPixelCanvas = class (TFPCustomCanvas)
   private
     FHashWidth : word;
     FRelativeBI : boolean;
   protected
+    procedure DoCopyRect(x, y: integer; canvas: TFPCustomCanvas; const SourceRect: TRect); override;
     function DoCreateDefaultFont : TFPCustomFont; override;
     function DoCreateDefaultPen : TFPCustomPen; override;
     function DoCreateDefaultBrush : TFPCustomBrush; override;
+    procedure DoDraw(x, y: integer; const image: TFPCustomImage); override;
     procedure DoTextOut (x,y:integer;text:string); override;
     procedure DoGetTextSize (text:string; var w,h:integer); override;
     function  DoGetTextHeight (text:string) : integer; override;
@@ -73,12 +77,26 @@ begin
   raise PixelCanvasException.Create(sErrNotAvailable);
 end;
 
-constructor TFPPixelCanvas.Create;
+constructor TFPPixelCanvas.create;
 begin
   inherited;
   FHashWidth := DefaultHashWidth;
 end;
 
+procedure TFPPixelCanvas.DoCopyRect(x, y: integer; canvas: TFPCustomCanvas; const SourceRect: TRect);
+Var
+  W,H,XS1,XS2,YS1,YS2 : Integer;
+
+begin
+  XS1:=SourceRect.Left;
+  XS2:=SourceRect.Right;
+  YS1:=SourceRect.Top;
+  YS2:=SourceRect.Bottom;
+  For H:=0 to YS2-YS1 do
+    For W:=0 to XS2-XS1 do
+      Colors[x+h,y+h]:=Canvas.Colors[XS1+W,YS1+H];
+end;
+
 function TFPPixelCanvas.DoCreateDefaultFont : TFPCustomFont;
 begin
   result := TFPEmptyFont.Create;
@@ -108,6 +126,17 @@ begin
   result.Style := bsSolid;
 end;
 
+procedure TFPPixelCanvas.DoDraw(x, y: integer; const image: TFPCustomImage);
+
+Var
+  W,h : Integer;
+
+begin
+  For H:=0 to Image.Height-1 do
+    For W:=0 to Image.Width-1 do
+      Colors[x+w,y+h]:=Image.Colors[W,H];
+end;
+
 procedure TFPPixelCanvas.DoTextOut (x,y:integer;text:string);
 begin
   NotImplemented;
@@ -365,4 +394,5 @@ begin
   end;
 end;
 
+
 end.

packages/fcl-image/src/fpreadjpeg.pas

@@ -211,7 +211,7 @@ var
     if (FInfo.out_color_space = JCS_GRAYSCALE) then 
       begin
       FInfo.quantize_colors := True;
-      FInfo.desired_number_of_colors := 236;
+      FInfo.desired_number_of_colors := 256;
       end;
 
     if FPerformance = jpBestSpeed then 

packages/fcl-image/src/fpwritejpeg.pas

@@ -44,7 +44,7 @@ type
     destructor Destroy; override;
     property CompressionQuality: TFPJPEGCompressionQuality read FQuality write FQuality;
     property ProgressiveEncoding: boolean read FProgressiveEncoding write FProgressiveEncoding;
-    property GrayScale: boolean read FGrayscale;
+    property GrayScale: boolean read FGrayscale write FGrayScale;
   end;
 
 implementation
@@ -125,10 +125,16 @@ var
   begin
     FInfo.image_width := Img.Width;
     FInfo.image_height := Img.Height;
-    FInfo.input_components := 3; // RGB has 3 components
-    FInfo.in_color_space := JCS_RGB;
     if FGrayscale then
-      jpeg_set_colorspace(@FInfo, JCS_GRAYSCALE);
+    begin
+      FInfo.input_components := 1;
+      FInfo.in_color_space := JCS_GRAYSCALE;
+    end
+    else
+    begin
+      FInfo.input_components := 3; // RGB has 3 components
+      FInfo.in_color_space := JCS_RGB;
+    end;
 
     jpeg_set_defaults(@FInfo);
     jpeg_set_quality(@FInfo, FQuality, True);
@@ -157,6 +163,10 @@ var
     try
       y:=0;
       while (FInfo.next_scanline < FInfo.image_height) do begin
+        if FGrayscale then
+        for x:=0 to FInfo.image_width-1 do
+          SampRow^[x]:=CalculateGray(Img.Colors[x,y]) shr 8
+        else
         for x:=0 to FInfo.image_width-1 do begin
           Color:=Img.Colors[x,y];
           SampRow^[x*3+0]:=Color.Red shr 8;

packages/fcl-image/src/freetype.pp

@@ -48,11 +48,10 @@ type
   PFontBitmap = ^TFontBitmap;
 
 
-  TStringBitMaps = class
+  TBaseStringBitMaps = class
     private
       FList : TList;
       FBounds : TRect;
-      FText : string;
       FMode : TBitmapType;
       function GetCount : integer;
       function GetBitmap (index:integer) : PFontBitmap;
@@ -61,17 +60,30 @@ type
       constructor Create (ACount : integer);
       destructor destroy; override;
       procedure GetBoundRect (out aRect : TRect);
-      property Text : string read FText;
       property Mode : TBitmapType read FMode;
       property Count : integer read GetCount;
       property Bitmaps[index:integer] : PFontBitmap read GetBitmap;
   end;
 
+  TStringBitMaps = class(TBaseStringBitMaps)
+    private
+      FText : STring;
+    public
+      property Text : string read FText;
+  end;
+
+  TUnicodeStringBitMaps = class(TBaseStringBitMaps)
+  private
+    FText : UnicodeString;
+  public
+    property Text : Unicodestring read FText;
+  end;
+
   TFontManager = class;
 
   PMgrGlyph = ^TMgrGlyph;
   TMgrGlyph = record
-    Character : char;
+    Character : unicodechar;
     GlyphIndex : FT_UInt;
     Glyph : PFT_Glyph;
   end;
@@ -109,33 +121,41 @@ type
       function GetSearchPath : string;
       procedure SetSearchPath (AValue : string);
       procedure SetExtention (AValue : string);
+      Procedure DoMakeString (Text : Array of cardinal; ABitmaps  : TBaseStringBitmaps);
+      Procedure DoMakeString (Text : Array of cardinal; angle: real; ABitmaps  : TBaseStringBitmaps);
     protected
       function GetFontId (afilename:string; anindex:integer) : integer;
       function CreateFont (afilename:string; anindex:integer) : integer;
-      function SearchFont (afilename:string) : string;
       function GetFont (FontID:integer) : TMgrFont;
       procedure GetSize (aSize, aResolution : integer);
       function CreateSize (aSize, aResolution : integer) : PMgrSize;
       procedure SetPixelSize (aSize, aResolution : integer);
-      function GetGlyph (c : char) : PMgrGlyph;
-      function CreateGlyph (c : char) : PMgrGlyph;
+      function GetGlyph (c : cardinal) : PMgrGlyph;
+      function CreateGlyph (c : cardinal) : PMgrGlyph;
       procedure MakeTransformation (angle:real; out Transformation:FT_Matrix);
       procedure InitMakeString (FontID, Size:integer);
       function MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
       function MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+      function MakeString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+      function MakeString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
     public
       constructor Create;
       destructor destroy; override;
+      function SearchFont(afilename: string; doraise: boolean=true): string;
       function RequestFont (afilename:string) : integer;
       function RequestFont (afilename:string; anindex:integer) : integer;
       function GetFreeTypeFont (aFontID:integer) : PFT_Face;
       function GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+      function GetString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
       // Black and white
       function GetStringGray (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+      function GetStringGray (FontId:integer; Text:unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
       // Anti Aliased gray scale
       function GetString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+      function GetString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
       // Black and white, following the direction of the font (left to right, top to bottom, ...)
-      function GetStringGray (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+      function GetStringGray (FontId:integer; Text: String; Size:integer) : TStringBitmaps;
+      function GetStringGray (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
       // Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
       property SearchPath : string read GetSearchPath write SetSearchPath;
       property DefaultExtention : string read FExtention write SetExtention;
@@ -381,11 +401,12 @@ begin
     AValue := '';
 end;
 
-function TFontManager.SearchFont (afilename:string) : string;
+function TFontManager.SearchFont (afilename:string; doraise : boolean = true) : string;
 // returns full filename of font, taking SearchPath in account
 var p,fn : string;
     r : integer;
 begin
+  Result:='';
   if (pos('.', afilename)=0) and (DefaultFontExtention<>'') then
     fn := afilename + DefaultFontExtention
   else
@@ -401,14 +422,12 @@ begin
       repeat
         dec (r);
       until (r < 0) or FileExists(FPaths[r]+fn);
-      if r < 0 then
-        raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [fn])
-      else
-        result := FPaths[r]+fn;
+      if r >= 0 then
+        Result := FPaths[r]+fn;
       end
-    else
-      raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [afilename]);
     end;
+  if (Result='') and doRaise then
+    raise FreeTypeException.CreateFmt (sErrFontFileNotFound, [fn])
 end;
 
 function TFontManager.GetFontId (afilename:string; anindex:integer) : integer;
@@ -527,13 +546,13 @@ begin
     end;
 end;
 
-function TFontManager.CreateGlyph (c : char) : PMgrGlyph;
+function TFontManager.CreateGlyph (c : cardinal) : PMgrGlyph;
 var e : integer;
 begin
   new (result);
   FillByte(Result^,SizeOf(Result),0);
-  result^.character := c;
-  result^.GlyphIndex := FT_Get_Char_Index (CurFont.font, ord(c));
+  result^.character := unicodechar(c);
+  result^.GlyphIndex := FT_Get_Char_Index (CurFont.font, c);
   //WriteFT_Face(CurFont.Font);
   e := FT_Load_Glyph (CurFont.font, result^.GlyphIndex, FT_Load_Default);
   if e <> 0 then
@@ -548,7 +567,7 @@ begin
   CurSize^.Glyphs.Add (result);
 end;
 
-function TFontManager.GetGlyph (c : char) : PMgrGlyph;
+function TFontManager.GetGlyph (c : cardinal) : PMgrGlyph;
 var r : integer;
 begin
   With CurSize^ do
@@ -556,7 +575,7 @@ begin
     r := Glyphs.Count;
     repeat
       dec (r)
-    until (r < 0) or (PMgrGlyph(Glyphs[r])^.character = c);
+    until (r < 0) or (PMgrGlyph(Glyphs[r])^.character = unicodechar(c));
     if r < 0 then
       result := CreateGlyph (c)
     else
@@ -571,10 +590,48 @@ begin
 end;
 
 function TFontManager.MakeString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
+
+Var
+  T : Array of cardinal;
+  C,I : Integer;
+
+begin
+  CurFont := GetFont(FontID);
+  InitMakeString (FontID, Size);
+  c := length(text);
+  result := TStringBitmaps.Create(c);
+  result.FText := Text;
+  SetLength(T,Length(Text));
+  For I:=1 to Length(Text) do
+    T[I-1]:=Ord(Text[i]);
+  DoMakeString(T,Angle,Result);
+end;
+
+function TFontManager.MakeString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+
+Var
+  T : Array of cardinal;
+  c,I : Integer;
+
+begin
+  CurFont := GetFont(FontID);
+  InitMakeString (FontID, Size);
+  c := length(text);
+  result := TUnicodeStringBitmaps.Create(c);
+  result.FText := Text;
+  SetLength(T,C);
+  For I:=1 to c do
+    T[I-1]:=Ord(Text[i]);
+  DoMakeString(T,Angle,Result);
+end;
+
+
+procedure TFontManager.DoMakeString(Text: Array of cardinal; angle:real; ABitmaps : TBaseStringBitmaps);
+
 var g : PMgrGlyph;
     bm : PFT_BitmapGlyph;
     gl : PFT_Glyph;
-    prevIndex, prevx, c, r, rx : integer;
+    prevIndex, prevx, r, rx : integer;
     pre, adv, pos, kern : FT_Vector;
     buf : PByteArray;
     reverse : boolean;
@@ -582,19 +639,15 @@ var g : PMgrGlyph;
     FBM : PFontBitmap;
 
 begin
-  CurFont := GetFont(FontID);
   if  (Angle = 0) or   // no angle asked, or can't work with angles (not scalable)
       ((CurFont.Font^.face_flags and FT_FACE_FLAG_SCALABLE)=0) then
-    result := MakeString (FontID, Text, Size)
+    DoMakeString (Text, ABitmaps)
   else
     begin
-    InitMakeString (FontID, Size);
-    c := length(text);
-    result := TStringBitmaps.Create(c);
     if (CurRenderMode = FT_RENDER_MODE_MONO) then
-      result.FMode := btBlackWhite
+      ABitmaps.FMode := btBlackWhite
     else
-      result.FMode := bt256Gray;
+      ABitmaps.FMode := bt256Gray;
     MakeTransformation (angle, trans);
     prevIndex := 0;
     prevx := 0;
@@ -602,10 +655,10 @@ begin
     pos.y := 0;
     pre.x := 0;
     pre.y := 0;
-    for r := 0 to c-1 do
+    for r := 0 to Length(Text)-1 do
       begin
       // retrieve loaded glyph
-      g := GetGlyph (Text[r+1]);
+      g := GetGlyph (Text[r]);
       // check kerning
       if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
         begin
@@ -625,7 +678,7 @@ begin
       FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, nil, true),sErrMakingString4);
       // Copy what is needed to record
       bm := PFT_BitmapGlyph(gl);
-      FBM:=result.Bitmaps[r];
+      FBM:=ABitmaps.Bitmaps[r];
       with FBM^ do
         begin
         with gl^.advance do
@@ -675,36 +728,68 @@ begin
       // finish rendered glyph
       FT_Done_Glyph (gl);
       end;
-    result.FText := Text;
-    result.CalculateGlobals;
+    ABitmaps.CalculateGlobals;
     end;
 end;
 
 function TFontManager.MakeString (FontId:integer; Text:string; Size:integer) : TStringBitmaps;
+
+Var
+  T : Array of Cardinal;
+  C,I : Integer;
+  
+begin
+  CurFont := GetFont(FontID);
+  InitMakeString (FontID, Size);
+  c := length(text);
+  result := TStringBitmaps.Create(c);
+  result.FText := Text;
+  SetLength(T,Length(Text));
+  For I:=1 to Length(Text) do
+    T[I-1]:=Ord(Text[i]);
+  DoMakeString(T,Result);
+end;
+
+function TFontManager.MakeString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
+
+Var
+  T : Array of Cardinal;
+  C,I : Integer;
+  
+begin
+  CurFont := GetFont(FontID);
+  InitMakeString (FontID, Size);
+  c := length(text);
+  result := TUnicodeStringBitmaps.Create(c);
+  result.FText := Text;
+  SetLength(T,C);
+  For I:=1 to C do
+    T[I-1]:=Ord(Text[i]);
+  DoMakeString(T,Result);
+end;
+
+Procedure TFontManager.DoMakeString (Text : Array of cardinal; ABitmaps  : TBaseStringBitmaps);
+
 var g : PMgrGlyph;
     bm : PFT_BitmapGlyph;
     gl : PFT_Glyph;
-    e, prevIndex, prevx, c, r, rx : integer;
+    e, prevIndex, prevx, r, rx : integer;
     pos, kern : FT_Vector;
     buf : PByteArray;
     reverse : boolean;
 begin
-  CurFont := GetFont(FontID);
-  InitMakeString (FontID, Size);
-  c := length(text);
-  result := TStringBitmaps.Create(c);
   if (CurRenderMode = FT_RENDER_MODE_MONO) then
-    result.FMode := btBlackWhite
+    ABitmaps.FMode := btBlackWhite
   else
-    result.FMode := bt256Gray;
+    ABitmaps.FMode := bt256Gray;
   prevIndex := 0;
   prevx := 0;
   pos.x := 0;
   pos.y := 0;
-  for r := 0 to c-1 do
+  for r := 0 to length(text)-1 do
     begin
     // retrieve loaded glyph
-    g := GetGlyph (Text[r+1]);
+    g := GetGlyph (Text[r]);
     // check kerning
     if UseKerning and (g^.glyphindex <>0) and (PrevIndex <> 0) then
       begin
@@ -719,7 +804,7 @@ begin
     FTCheck(FT_Glyph_To_Bitmap (gl, CurRenderMode, @pos, true),sErrMakingString4);
     // Copy what is needed to record
     bm := PFT_BitmapGlyph(gl);
-    with result.Bitmaps[r]^ do
+    with ABitmaps.Bitmaps[r]^ do
       begin
       with gl^.advance do
         begin
@@ -761,8 +846,7 @@ begin
     // finish rendered glyph
     FT_Done_Glyph (gl);
     end;
-  result.FText := Text;
-  result.CalculateGlobals;
+  ABitmaps.CalculateGlobals;
 end;
 
 function TFontManager.GetString (FontId:integer; Text:string; size:integer; angle:real) : TStringBitmaps;
@@ -795,6 +879,36 @@ begin
   result := MakeString (FontID, text, Size);
 end;
 
+function TFontManager.GetString (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+// Black and white
+begin
+  CurRenderMode := FT_RENDER_MODE_MONO;
+  result := MakeString (FontID, text, Size, angle);
+end;
+
+function TFontManager.GetStringGray (FontId:integer; Text:Unicodestring; size:integer; angle:real) : TUnicodeStringBitmaps;
+// Anti Aliased gray scale
+begin
+  CurRenderMode := FT_RENDER_MODE_NORMAL;
+  result := MakeString (FontID, text, Size, angle);
+end;
+
+{ Procedures without angle have own implementation to have better speed }
+
+function TFontManager.GetString (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
+// Black and white, following the direction of the font (left to right, top to bottom, ...)
+begin
+  CurRenderMode := FT_RENDER_MODE_MONO;
+  result := MakeString (FontID, text, Size);
+end;
+
+function TFontManager.GetStringGray (FontId:integer; Text:Unicodestring; Size:integer) : TUnicodeStringBitmaps;
+// Anti Aliased gray scale, following the direction of the font (left to right, top to bottom, ...)
+begin
+  CurRenderMode := FT_RENDER_MODE_NORMAL;
+  result := MakeString (FontID, text, Size);
+end;
+
 function TFontManager.RequestFont (afilename:string) : integer;
 begin
   result := RequestFont (afilename,0);
@@ -821,17 +935,17 @@ end;
 
 { TStringBitmaps }
 
-function TStringBitmaps.GetCount : integer;
+function TBaseStringBitmaps.GetCount : integer;
 begin
   result := FList.Count;
 end;
 
-function TStringBitmaps.GetBitmap (index:integer) : PFontBitmap;
+function TBaseStringBitmaps.GetBitmap (index:integer) : PFontBitmap;
 begin
   result := PFontBitmap(FList[index]);
 end;
 
-constructor TStringBitmaps.Create (ACount : integer);
+constructor TBaseStringBitmaps.Create (ACount : integer);
 var r : integer;
     bm : PFontBitmap;
 begin
@@ -846,7 +960,7 @@ begin
     end;
 end;
 
-destructor TStringBitmaps.destroy;
+destructor TBaseStringBitmaps.destroy;
 var r : integer;
     bm : PFontBitmap;
 begin
@@ -868,7 +982,7 @@ begin
 end;
 *)
 
-procedure TStringBitmaps.CalculateGlobals;
+procedure TBAseStringBitmaps.CalculateGlobals;
 var
   l,r : integer;
 
@@ -907,7 +1021,7 @@ begin
     end;
 end;
 
-procedure TStringBitmaps.GetBoundRect (out aRect : TRect);
+procedure TBaseStringBitmaps.GetBoundRect (out aRect : TRect);
 begin
   aRect := FBounds;
 end;

packages/fcl-image/src/ftfont.pp

@@ -27,12 +27,13 @@ type
   private
     FResolution : longword;
     FAntiAliased : boolean;
-    FLastText : TStringBitmaps;
+    FLastText : TBaseStringBitmaps;
     FIndex, FFontID : integer;
     FFace : PFT_Face;
     FAngle : real;
     procedure ClearLastText;
   protected
+    procedure DrawLastText (atX,atY:integer);
     procedure DrawChar (x,y:integer; data:PByteArray; pitch, width, height:integer); virtual;
     procedure DrawCharBW (x,y:integer; data:PByteArray; pitch, width, height:integer); virtual;
     procedure SetName (AValue:string); override;
@@ -47,7 +48,12 @@ type
     procedure DoGetTextSize (text:string; var w,h:integer); override;
     function DoGetTextHeight (text:string) : integer; override;
     function DoGetTextWidth (text:string) : integer; override;
+    procedure DoDrawText (atx,aty:integer; atext: unicodestring); override;
+    procedure DoGetTextSize (text:unicodestring; var w,h:integer); override;
+    function DoGetTextHeight (text:unicodestring) : integer; override;
+    function DoGetTextWidth (text: unicodestring) : integer; override;
     procedure GetText (aText:string);
+    procedure GetText (aText:unicodestring);
     procedure GetFace;
   public
     constructor create; override;
@@ -180,6 +186,36 @@ begin
     result := right - left;
 end;
 
+procedure TFreeTypeFont.DoGetTextSize (text:unicodestring; var w,h:integer);
+var r : TRect;
+begin
+  GetText (text);
+  FLastText.GetBoundRect (r);
+  with r do
+    begin
+    w := right - left;
+    h := top - bottom;
+    end;
+end;
+
+function TFreeTypeFont.DoGetTextHeight (text:unicodestring) : integer;
+var r : TRect;
+begin
+  GetText (text);
+  FLastText.GetBoundRect (r);
+  with r do
+    result := top - bottom;
+end;
+
+function TFreeTypeFont.DoGetTextWidth (text:unicodestring) : integer;
+var r : TRect;
+begin
+  GetText (text);
+  FLastText.GetBoundRect (r);
+  with r do
+    result := right - left;
+end;
+
 procedure TFreeTypeFont.SetFlags (index:integer; AValue:boolean);
 begin
   if not (index in [5,6]) then   // bold,italic
@@ -213,7 +249,39 @@ var b : boolean;
 begin
   if assigned (FLastText) then
     begin
-    if CompareStr(FLastText.Text,aText) <> 0 then
+    if FLastText.InheritsFrom(TUnicodeStringBitmaps) or  (CompareStr(TStringBitMaps(FLastText).Text,aText) <> 0) then
+      begin
+      FLastText.Free;
+      b := true;
+      end
+    else
+      begin
+      if FAntiAliased then
+        b := (FLastText.mode <> bt256Gray)
+      else
+        b := (FLastText.mode <> btBlackWhite);
+      if b then
+        FLastText.Free;
+      end;
+    end
+  else
+    b := true;
+  if b then
+    begin
+    FontMgr.Resolution := FResolution;
+    if FAntiAliased then
+      FLastText := FontMgr.GetStringGray (FFontId, aText, Size, Angle)
+    else
+      FLastText := FontMgr.GetString (FFontId, aText, Size, Angle);
+    end;
+end;
+
+procedure TFreeTypeFont.GetText (aText:Unicodestring);
+var b : boolean;
+begin
+  if assigned (FLastText) then
+    begin
+    if FLastText.InheritsFrom(TStringBitmaps) or  (TUnicodeStringBitMaps(FLastText).Text<>aText) then
       begin
       FLastText.Free;
       b := true;
@@ -240,10 +308,25 @@ begin
     end;
 end;
 
+procedure TFreeTypeFont.DoDrawText (atX,atY:integer; atext:unicodestring);
+
+begin
+  GetText (atext);
+  DrawLastText(atX,atY);
+end;
+
 procedure TFreeTypeFont.DoDrawText (atX,atY:integer; atext:string);
-var r : integer;
+
 begin
   GetText (atext);
+  DrawLastText(atX,atY);
+end;
+
+procedure TFreeTypeFont.DrawLastText (atX,atY:integer);
+
+var r : integer;
+
+begin
   with FLastText do
     for r := 0 to count-1 do
       with Bitmaps[r]^ do

packages/fcl-js/examples/fpjsmin.pp

@@ -0,0 +1,21 @@
+{$mode objfpc}{$h+}
+{$inline on}
+program fpjsmin;
+
+uses jsminifier;
+
+
+begin
+  if ParamCount<>2 then
+    begin
+    Writeln('Usage: fpjsmin infile outfile');
+    halt(1);
+    end;
+  With TJSONMinifier.Create(Nil) do
+    try
+       FileHeader.Add(paramstr(1));
+       Execute(ParamStr(1),ParamStr(2));
+    finally
+      Free
+    end;
+end.

packages/fcl-js/fpmake.pp

@@ -25,6 +25,8 @@ begin
     P.Description := 'Javascript scanner/parser/syntax tree units';
     P.OSes:=AllOSes-[embedded,msdos];
 
+    P.Dependencies.Add('fcl-base');
+
     P.SourcePath.Add('src');
     P.IncludePath.Add('src');
 
@@ -37,6 +39,8 @@ begin
       T.ResourceStrings:=true;
     T:=P.Targets.AddUnit('jswriter.pp');
       T.ResourceStrings:=true;
+    T:=P.Targets.AddUnit('jsminifier.pp');
+      T.ResourceStrings:=true;
 {$ifndef ALLPACKAGES}
     Run;
     end;

packages/fcl-js/src/jsbase.pp

@@ -1,3 +1,18 @@
+{ ********************************************************************* 
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2016 Michael Van Canneyt.
+       
+    Javascript base definitions
+            
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+                   
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+                                
+  **********************************************************************}
+                                 
 unit jsbase;
 
 {$mode objfpc}{$H+}
@@ -10,7 +25,9 @@ uses
 Type
   TJSType = (jstUNDEFINED,jstNull,jstBoolean,jstNumber,jstString,jstObject,jstReference,JSTCompletion);
 
-  TJSString = WideString;
+  TJSString = UnicodeString;
+  TJSChar = WideChar;
+  TJSPChar = PWideChar;
   TJSNumber = Double;
 
   { TJSValue }
@@ -24,6 +41,7 @@ Type
       1 : (F : TJSNumber);
       2 : (I : Integer);
     end;
+    FCustomValue: TJSString;
     procedure ClearValue(ANewValue: TJSType);
     function GetAsBoolean: Boolean;
     function GetAsCompletion: TObject;
@@ -49,6 +67,7 @@ Type
     Constructor Create(AString: TJSString);
     Destructor Destroy; override;
     Property ValueType : TJSType Read FValueType;
+    Property CustomValue: TJSString Read FCustomValue Write FCustomValue;
     Property IsUndefined : Boolean Read GetIsUndefined Write SetIsUndefined;
     Property IsNull : Boolean Read GetIsNull Write SetIsNull;
     Property AsNumber : TJSNumber Read GetAsNumber Write SetAsNumber;
@@ -59,10 +78,90 @@ Type
     Property AsCompletion : TObject Read GetAsCompletion Write SetAsCompletion;
   end;
 
+function IsValidJSIdentifier(Name: TJSString; AllowEscapeSeq: boolean = false): boolean;
+
 implementation
 
-{ TJSValue }
+function IsValidJSIdentifier(Name: TJSString; AllowEscapeSeq: boolean): boolean;
+var
+  p: TJSPChar;
+  i: Integer;
+begin
+  Result:=false;
+  if Name='' then exit;
+  p:=TJSPChar(Name);
+  repeat
+    case p^ of
+    #0:
+      if p-TJSPChar(Name)=length(Name) then
+        exit(true)
+      else
+        exit;
+    '0'..'9':
+      if p=TJSPChar(Name) then
+        exit
+      else
+        inc(p);
+    'a'..'z','A'..'Z','_','$': inc(p);
+    '\':
+      begin
+      if not AllowEscapeSeq then exit;
+      inc(p);
+      if p^='x' then
+        begin
+        // \x00
+        for i:=1 to 2 do
+          begin
+          inc(p);
+          if not (p^ in ['0'..'9','a'..'f','A'..'F']) then exit;
+          end;
+        end
+      else if p^='u' then
+        begin
+        inc(p);
+        if p^='{' then
+          begin
+          // \u{00000}
+          i:=0;
+          repeat
+            inc(p);
+            case p^ of
+            '}': break;
+            '0'..'9': i:=i*16+ord(p^)-ord('0');
+            'a'..'f': i:=i*16+ord(p^)-ord('a')+10;
+            'A'..'F': i:=i*16+ord(p^)-ord('A')+10;
+            else exit;
+            end;
+            if i>$10FFFF then exit;
+          until false;
+          inc(p);
+          end
+        else
+          begin
+          // \u0000
+          for i:=1 to 4 do
+            begin
+            inc(p);
+            if not (p^ in ['0'..'9','a'..'f','A'..'F']) then exit;
+            end;
+          end;
+        end
+      else
+        exit; // unknown sequence
+      end;
+    #$200C,#$200D: inc(p); // zero width non-joiner/joiner
+    #$00AA..#$2000,
+    #$200E..#$D7FF:
+      inc(p); // ToDo: only those with ID_START/ID_CONTINUE see https://codepoints.net/search?IDC=1
+    #$D800..#$DBFF:
+      inc(p,2); // see above
+    else
+      exit;
+    end;
+  until false;
+end;
 
+{ TJSValue }
 
 function TJSValue.GetAsBoolean: Boolean;
 begin
@@ -80,25 +179,33 @@ end;
 function TJSValue.GetAsNumber: TJSNumber;
 begin
   If (ValueType=jstNumber) then
-    Result:=FValue.F;
+    Result:=FValue.F
+  else
+    Result:=0.0;
 end;
 
 function TJSValue.GetAsObject: TObject;
 begin
   If (ValueType=jstObject) then
-    Result:=TObject(FValue.P);
+    Result:=TObject(FValue.P)
+  else
+    Result:=nil;
 end;
 
 function TJSValue.GetAsReference: TObject;
 begin
   If (ValueType=jstReference) then
-    Result:=TObject(FValue.P);
+    Result:=TObject(FValue.P)
+  else
+    Result:=nil;
 end;
 
 function TJSValue.GetAsString: TJSString;
 begin
   If (ValueType=jstString) then
-    Result:=String(FValue.P);
+    Result:=TJSString(FValue.P)
+  else
+    Result:='';
 end;
 
 function TJSValue.GetIsNull: Boolean;
@@ -121,6 +228,7 @@ begin
     FValue.I:=0;
   end;
   FValueType:=ANewValue;
+  FCustomValue:='';
 end;
 
 procedure TJSValue.SetAsBoolean(const AValue: Boolean);
@@ -156,45 +264,51 @@ end;
 procedure TJSValue.SetAsString(const AValue: TJSString);
 begin
   ClearValue(jstString);
-  String(FValue.P):=AValue;
+  TJSString(FValue.P):=AValue;
 end;
 
 procedure TJSValue.SetIsNull(const AValue: Boolean);
 begin
-  ClearValue(jstNull);
+  if AValue then
+    ClearValue(jstNull)
+  else if IsNull then
+    ClearValue(jstUNDEFINED);
 end;
 
 procedure TJSValue.SetIsUndefined(const AValue: Boolean);
 begin
-  ClearValue(jstUndefined);
+  if AValue then
+    ClearValue(jstUndefined)
+  else if IsUndefined then
+    ClearValue(jstNull);
 end;
 
-Constructor TJSValue.CreateNull;
+constructor TJSValue.CreateNull;
 begin
   IsNull:=True;
 end;
 
-Constructor TJSValue.Create;
+constructor TJSValue.Create;
 begin
   IsUndefined:=True;
 end;
 
-Constructor TJSValue.Create(ANumber: TJSNumber);
+constructor TJSValue.Create(ANumber: TJSNumber);
 begin
   AsNumber:=ANumber;
 end;
 
-Constructor TJSValue.Create(ABoolean: Boolean);
+constructor TJSValue.Create(ABoolean: Boolean);
 begin
   AsBoolean:=ABoolean;
 end;
 
-Constructor TJSValue.Create(AString: TJSString);
+constructor TJSValue.Create(AString: TJSString);
 begin
-  AsString:=AString
+  AsString:=AString;
 end;
 
-Destructor TJSValue.Destroy;
+destructor TJSValue.Destroy;
 begin
   ClearValue(jstUndefined);
   inherited Destroy;

packages/fcl-js/src/jsminifier.pp

@@ -0,0 +1,440 @@
+{ ********************************************************************* 
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2016 Michael Van Canneyt.
+       
+    Javascript minifier
+            
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+                   
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+                                
+  **********************************************************************}
+{ ---------------------------------------------------------------------
+  Javascript minifier, based on an implementation by Douglas Crockford,
+  see original copyright.
+  ---------------------------------------------------------------------}
+{ jsmin.c
+   2013-03-29
+
+Copyright (c) 2002 Douglas Crockford  (www.crockford.com)
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+The Software shall be used for Good, not Evil.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+}
+
+unit jsminifier;
+
+{$mode objfpc}{$H+}
+{$inline on}
+
+interface
+
+uses sysutils,classes,bufstream;
+
+
+Const
+  EOS = #0;
+
+Type
+
+  { TJSONMinifier }
+  EJSONMinifier = Class(Exception);
+
+  TJSONMinifier = Class(TComponent)
+  Private
+    FA : char;
+    FB : char;
+    FFileHeader: TStrings;
+    FLookahead : char;
+    FX : char;
+    FY : char ;
+    Fin : TStream;
+    Fout : TStream;
+    procedure SetFileHeader(AValue: TStrings);
+  Protected
+    // Token reading routines
+    function Peek : char;
+    function Get : char;inline;
+    function Next : char;
+    // Token writing routines
+    procedure Putc(c: char);inline;
+    Procedure Reset;
+    procedure DoHeader; virtual;
+    procedure Error(Const Msg: string);
+    Class Function isAlphaNum(c: char): boolean;
+    Class Function iif(B : Boolean; Const ifTrue,ifFalse : integer) : integer; inline;
+    procedure Action(d: Byte);
+    procedure Minify;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    Procedure Execute(Const SourceFilename,DestFilename : String);
+    Procedure Execute(Source,Dest : TStream);
+    Procedure Execute(SourceFilenames : TStrings; Const DestFilename : String);
+    Procedure Execute(SourceFileNames : Array of string; Const DestFilename : String);
+  Published
+    Property FileHeader : TStrings Read FFileHeader Write SetFileHeader;
+  end;
+
+Implementation
+
+Resourcestring
+  SErrUnterminatedComment = 'Unterminated comment.';
+  SErrUnterminatedStringLiteral = 'Unterminated string literal.';
+  SErrUnterminatedSetInRegexp = 'Unterminated set in Regular Expression literal.';
+  SerrUnterminatedRegexp = 'Unterminated Regular Expression literal.';
+
+class function TJSONMinifier.iif(B: Boolean; const ifTrue, ifFalse: integer
+  ): integer;
+
+begin
+  if B then
+    Result:=ifTrue
+  else
+    Result:=ifFalse;
+end;
+
+procedure TJSONMinifier.Error(const Msg: string);
+
+begin
+  Raise EJSONMinifier.Create('JSMIN Error: '+Msg);
+end;
+
+procedure TJSONMinifier.SetFileHeader(AValue: TStrings);
+begin
+  if FFileHeader=AValue then Exit;
+  FFileHeader.Assign(AValue);
+end;
+
+procedure TJSONMinifier.Reset;
+
+begin
+  FA:=EOS;
+  FB:=EOS;
+  FLookahead:=EOS;
+  FX:=EOS;
+  FY:=EOS;
+end;
+
+class function TJSONMinifier.isAlphaNum(c: char): boolean;
+
+begin
+  Result:= (C in ['a'..'z']) or (c in ['0'..'9']) or (c in ['A'..'Z']) or (C in ['_','$','\']) or (c > #126);
+end;
+
+
+function TJSONMinifier.Get: char;
+
+begin
+  Result:=FLookahead;
+  FLookahead:=EOS;
+  if (Result=EOS) then
+    if Fin.Read(Result,sizeof(Result))=0 then exit;
+  if (Result>' ') or (Result in [#10,EOS]) then
+    Exit;
+  if (Result=#13) then
+    Result:=#10
+  else
+    Result:=' ';
+end;
+
+
+function TJSONMinifier.Peek: char;
+begin
+  FLookahead := get();
+  result:=FLookahead;
+end;
+
+function TJSONMinifier.Next: char;
+
+var
+ c : char;
+
+begin
+  c:= get();
+  if (c='/') then
+    case peek of
+      '/': Repeat
+             c := get();
+           until (c <= #10);
+      '*':
+           begin
+           Get();
+           while (c <> ' ') do
+             case get of
+               '*':
+                 begin
+                 if (peek()= '/') then
+                   begin
+                   get();
+                   c:=' ';
+                   end;
+                 end;
+               EOS:
+                 Error(SErrUnterminatedComment);
+              end;
+           end;
+    end;
+  FY:=FX;
+  FX:=c;
+  Result:=c;
+end;
+
+procedure TJSONMinifier.Putc(c: char);
+
+begin
+  Fout.writebuffer(c,sizeof(c));
+end;
+
+procedure TJSONMinifier.Action(d : Byte);
+
+  Procedure Do1;
+
+  begin
+    putc(FA);
+    if ((FY in [#10,' '])
+        and (FA in ['+','-','*','/'])
+        and (FB in ['+','-','*','/'])) then
+      putc(FY);
+  end;
+
+  Procedure Do2;
+
+  begin
+    FA:=FB;
+    if (FA in ['''','"','`']) then
+      While true do
+        begin
+        putc(FA);
+        FA:= get();
+        if (FA=FB) then
+          break;
+        if (FA='\') then
+          begin
+          putc(FA);
+          FA:=get();
+          end;
+        if (FA=EOS) then
+          Error(SErrUnterminatedStringLiteral);
+        end;
+  end;
+
+begin
+  if (D=1) then
+    Do1;
+  if (D in [1,2]) then
+    Do2;
+  FB := next();
+  if (FB='/') and (FA in ['(',',','=',':','[','!','&','|','?','+','-','~','*','/','{',#10]) then
+    begin
+    putc(FA);
+    if (FA in ['/','*']) then
+       putc(' ');
+    putc(FB);
+    While true do
+      begin
+      FA := get();
+      if (FA='[') then
+        begin
+        While true do
+          begin
+          putc(FA);
+          FA := get();
+          if (FA = ']') then
+            break;
+          if (FA = '\') then
+            begin
+            putc(FA);
+            FA := get();
+            end;
+          if (FA = EOS) then
+            Error(SErrUnterminatedSetInRegexp);
+          end
+        end
+      else if (FA = '/') then
+        begin
+        case (peek()) of
+           '/', '*':
+            Error(SErrUnterminatedSetInRegexp);
+        end;
+        Break;
+        end
+      else if (FA ='\') then
+        begin
+        putc(FA);
+        FA := get();
+        end;
+      if (FA = EOS) then
+        Error(SErrUnterminatedRegexp);
+      putc(FA);
+      end;
+    FB := next();
+    end;
+end;
+
+
+procedure TJSONMinifier.Minify;
+
+begin
+  if (peek()= #$EF) then
+    begin
+    get();
+    get();
+    get();
+    end;
+  FA:=#10;
+  action(3);
+  while (FA <> EOS) do
+    begin
+    case (FA) of
+      ' ':
+        action(iif(isAlphanum(FB),1,2));
+      #10:
+        case (FB) of
+          '{', '[', '(', '+', '-', '!', '~':
+            Action(1);
+          ' ':
+                Action(3);
+        else
+          Action(iif(isAlphanum(FB), 1 , 2));
+        end;
+    else
+      case (FB) of
+        ' ':
+          Action(iif(isAlphanum(FA),1,3));
+        #10:
+          case (FA) of
+            '}',']',')','+','-','"', '''', '`':
+              Action(1);
+          else
+            Action(iif(isAlphanum(FA), 1, 3));
+         end;
+      else
+        Action(1);
+      end;
+    end;
+    end;
+end;
+
+constructor TJSONMinifier.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FFileHeader:=TStringList.Create;
+end;
+
+destructor TJSONMinifier.Destroy;
+begin
+  FreeAndNil(FFileHeader);
+  inherited Destroy;
+end;
+
+procedure TJSONMinifier.Execute(const SourceFilename, DestFilename: String);
+
+Var
+ Src,Dest : TBufStream;
+
+begin
+ Dest:=Nil;
+ Src:=TReadBufStream.Create(TFileStream.Create(SourceFileName,fmOpenRead or fmShareDenyWrite),1000);
+ try
+   Src.SourceOwner:=True;
+   Dest:=TWriteBufStream.Create(TFileStream.create(DestFileName,fmCreate),1000);
+   Dest.SourceOwner:=True;
+   Execute(Src,Dest);
+ finally
+   Src.Free;
+   Dest.Free;
+ end;
+end;
+
+procedure TJSONMinifier.DoHeader;
+
+Var
+  S,L : String;
+
+begin
+  For S in FFileHeader do
+    begin
+    L:='// '+S+sLineBreak;
+    Fout.WriteBuffer(L[1],Length(L));
+    end;
+end;
+
+procedure TJSONMinifier.Execute(Source, Dest: TStream);
+
+begin
+  Fin:=Source;
+  Fout:=Dest;
+  try
+    Reset;
+    DoHeader;
+    Minify;
+  finally
+    Fin:=Nil;
+    Fout:=Nil;
+  end;
+end;
+
+procedure TJSONMinifier.Execute(SourceFilenames: TStrings;const DestFilename: String);
+
+Var
+  Src,Dest : TBufStream;
+  I : Integer;
+
+begin
+ Dest:=Src;
+ Dest:=TWriteBufStream.Create(TFileStream.create(DestFileName,fmCreate),1000);
+ try
+   Dest.SourceOwner:=True;
+   for I:=0 to SourceFileNames.Count-1 do
+     begin
+     Src:=TReadBufStream.Create(TFileStream.Create(SourceFileNames[i],fmOpenRead or fmShareDenyWrite),1000);
+     Src.SourceOwner:=True;
+     Execute(Src,Dest);
+     FreeAndNil(Src);
+     end;
+ finally
+   FreeAndNil(Src);
+   FreeAndNil(Dest);
+ end;
+end;
+
+procedure TJSONMinifier.Execute(SourceFileNames: array of string;
+  const DestFilename: String);
+
+Var
+  S : TStrings;
+
+begin
+  S:=TStringList.Create;
+  try
+    S.AddStrings(SourceFileNames);
+    Execute(S,DestFileName);
+  finally
+    S.Free;
+  end;
+end;
+
+
+end.
+

packages/fcl-js/src/jsparser.pp

@@ -1,3 +1,17 @@
+{ ********************************************************************* 
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2016 Michael Van Canneyt.
+       
+    Javascript parser
+            
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+                   
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+                                
+  **********************************************************************}
 unit jsparser;
 
 { $define debugparser}
@@ -25,8 +39,6 @@ Type
     FPrevious,
     FCurrent : TJSToken;
     FCurrentString : String;
-    FNextNewLine : Boolean;
-    FNextBol : Boolean;
     FFreeScanner : Boolean;
     FCurrentVars : TJSElementNodes;
     FPeekToken: TJSToken;
@@ -141,7 +153,7 @@ Resourcestring
   SErrCatchFinallyExpected   = 'Unexpected token: Expected ''catch'' or ''finally''';
   SErrArgumentsExpected      = 'Unexpected token: Expected '','' or '')'', got %s';
   SErrArrayEnd               = 'Unexpected token: Expected '','' or '']'', got %s';
-  SErrObjectEnd              = 'Unexpected token: Expected '','' or ''}'', got %s';
+  //SErrObjectEnd              = 'Unexpected token: Expected '','' or ''}'', got %s';
   SErrObjectElement          = 'Unexpected token: Expected string, identifier or number after '','' got: %s';
   SErrLiteralExpected        = 'Unexpected token: Expected: null, true, false, number, string, or regex, got: %s';
   SErrInvalidnumber          = 'Invalid numerical value: %s';
@@ -176,6 +188,7 @@ begin
     FCurrent:=FScanner.FetchToken;
     FCurrentString:=FScanner.CurTokenString;
     end;
+  Result:=FCurrent;
   {$ifdef debugparser}Writeln('GetNextToken (',FScanner.CurLine,',',FScanner.CurColumn,'): ',GetEnumName(TypeInfo(TJSToken),Ord(FCurrent)), ' As string: ',FCurrentString);{$endif debugparser}
 end;
 
@@ -557,8 +570,6 @@ function TJSParser.ParseObjectLiteral: TJSElement;
 Var
   N : TJSObjectLiteral;
   E : TJSObjectLiteralElement;
-  I : Integer;
-
 begin
   Consume(tjsCurlyBraceOpen);
   N:=TJSObjectLiteral(CreateElement(TJSObjectLiteral));
@@ -618,9 +629,6 @@ function TJSParser.ParseStringLiteral: TJSElement;
 
 Var
   L : TJSLiteral;
-  D : Double;
-  I : Integer;
-
 begin
     {$ifdef debugparser} Writeln('Parsing string literal');{$endif debugparser}
   Result:=Nil;
@@ -746,7 +754,6 @@ Var
   M  : TJSDotMemberExpression;
   N  : TJSNewMemberExpression;
   B  : TJSBracketMemberExpression;
-  C : TJSCallExpression;
   Done : Boolean;
 
 begin
@@ -758,7 +765,7 @@ begin
                   N:=TJSNewMemberExpression(CreateElement(TJSNewMemberExpression));
                   try
                     Result:=N;
-                    N.Mexpr:=ParseMemberExpression();
+                    N.MExpr:=ParseMemberExpression();
                     if (CurrentToken=tjsBraceOpen) then
                       N.Args:=ParseArguments;
                   except
@@ -1378,7 +1385,6 @@ end;
 function TJSParser.ParseVariableStatement : TJSElement;
 
 Var
-  E : TJSElement;
   V : TJSVariableStatement;
 
 begin
@@ -1429,7 +1435,7 @@ begin
     I:=TJSIfStatement(CreateElement(TJSIfStatement));
     I.Cond:=C;
     I.BTrue:=Btrue;
-    I.bfalse:=BFalse;
+    I.BFalse:=BFalse;
     Result:=I;
   except
     FreeAndNil(C);
@@ -1641,8 +1647,6 @@ function TJSParser.ParseWithStatement : TJSElement;
 
 Var
   W : TJSWithStatement;
-  N : TJSElement;
-
 begin
   W:=TJSWithStatement(CreateElement(TJSWithStatement));
   try
@@ -1655,6 +1659,7 @@ begin
     FreeAndNil(W);
     Raise;
   end;
+  Result:=W;
 end;
 
 function TJSParser.ParseSwitchStatement : TJSElement;
@@ -1662,7 +1667,6 @@ function TJSParser.ParseSwitchStatement : TJSElement;
 
 Var
   N : TJSSwitchStatement;
-  C : TJSElement;
   Ca : TJSCaseElement;
 
 begin
@@ -1813,6 +1817,7 @@ begin
         end
       else
         n:='';
+      if n='' then ; // what to do with that?
       Consume(tjsBraceOpen);
       F.AFunction:= TJSFuncDef.Create;
       Args:=ParseFormalParameterList;
@@ -1883,8 +1888,6 @@ function TJSParser.ParseLabeledStatement : TJSElement;
 Var
   OL : TJSLabelSet;
   LS : TJSLabeledStatement;
-  LN : String;
-
 begin
   LS:=TJSLabeledStatement(CreateElement(TJSLabeledStatement));
   try
@@ -2046,7 +2049,7 @@ begin
           If (PeekNextToken<>tjsBraceOpen) then
             begin
             F:=Self.ParseFunctionDeclaration;
-            Result.functions.AddNode.Node:=F;
+            Result.Functions.AddNode.Node:=F;
             end
           else
             begin
@@ -2095,8 +2098,6 @@ end;
 Function TJSParser.ParseProgram: TJSFunctionDeclarationStatement;
 
 Var
-  F : TJSFunctionDeclarationStatement;
-  FD : TJSFuncDef;
   B : TJSElement;
 begin
   {$ifdef debugparser} Writeln('>>> Entering FunctionDeclarationStatement');{$endif}

packages/fcl-js/src/jsscanner.pp

@@ -79,7 +79,6 @@ Type
     FCurToken: TJSToken;
     FCurTokenString: string;
     FCurLine: string;
-    FDefines: TStrings;
     TokenStr: PChar;
     FWasEndOfLine : Boolean;
     FSourceStream : TStream;
@@ -377,7 +376,7 @@ function TJSScanner.DoStringLiteral: TJSToken;
 Var
   Delim : Char;
   TokenStart : PChar;
-  Len,OLen,I : Integer;
+  Len,OLen: Integer;
   S : String;
 
 begin
@@ -516,18 +515,15 @@ begin
       FCurToken := Result;
       exit;
       end;
+    {$Push}
+    {$R-}
     I:=Succ(I);
+    {$Pop}
     end
 end;
 
 Function TJSScanner.FetchToken: TJSToken;
 
-
-var
-  TokenStart, CurPos: PChar;
-  i: TJSToken;
-  OldLength, SectionLength, NestingLevel, Index: Integer;
-
 begin
   if not (FCurtoken in [tjsWhiteSpace,tjsComment]) then
     FWasEndOfLine:=False;
@@ -541,7 +537,7 @@ begin
         exit;
         end;
       end;
-    CurPos:=TokenStr;
+    //CurPos:=TokenStr;
     FCurTokenString := '';
     case TokenStr[0] of
       #0:         // Empty line

packages/fcl-js/src/jssrcmap.pas

@@ -0,0 +1,621 @@
+{ *********************************************************************
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2015 Mattias Gaertner.
+
+    Javascript Source Map
+
+    See Source Maps Revision 3:
+    https://docs.google.com/document/d/1U1RGAehQwRypUTovF1KRlpiOFze0b-_2gc6fAH0KY0k/edit?hl=en_US&pli=1&pli=1#
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+  **********************************************************************}
+unit JSSrcMap;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, contnrs, fpjson;
+
+const
+  Base64Chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
+  DefaultSrcMapHeader = ')]}'+LineEnding;
+
+type
+
+  { TSourceMapSegment }
+
+  TSourceMapSegment = class
+  public
+    Index: integer; // index in FNodes
+    GeneratedLine: integer;
+    GeneratedColumn: integer;
+    SrcFileIndex: integer; // index in FSources
+    SrcLine: integer;
+    SrcColumn: integer;
+    NameIndex: integer; // index in FNames
+  end;
+
+  TSourceMapSrc = class
+  public
+    Filename: string;
+    Source: String;
+  end;
+
+  { TSourceMap }
+
+  TSourceMap = class
+  private
+    type
+
+      { TStringToIndex }
+
+      TStringToIndex = class
+      private
+        FItems: TFPHashList;
+      public
+        constructor Create;
+        destructor Destroy; override;
+        procedure Clear;
+        procedure Add(const Value: String; Index: integer);
+        function FindValue(const Value: String): integer;
+      end;
+  private
+    FAddMonotonous: boolean;
+    FHeader: String;
+    FGeneratedFilename: string;
+    FNames: TStrings; // in adding order
+    FNameToIndex: TStringToIndex; // name to index in FNames
+    FItems: TFPList; // TSourceMapSegment, in adding order
+    FSourceRoot: string;
+    FSources: TFPList; // list of TSourceMapSrc, in adding order
+    FSourceToIndex: TStringToIndex; // srcfile to index in FSources
+    FVersion: integer;
+    function GetNames(Index: integer): string;
+    function GetItems(Index: integer): TSourceMapSegment;
+    function GetSourceContents(Index: integer): String;
+    function GetSourceFiles(Index: integer): String;
+    procedure SetGeneratedFilename(const AValue: string);
+    procedure SetSourceContents(Index: integer; const AValue: String);
+  public
+    constructor Create(const aGeneratedFilename: string);
+    destructor Destroy; override;
+    procedure Clear; virtual;
+    function AddMapping(
+      GeneratedLine: integer; // 1-based
+      GeneratedCol: integer = 0; // 0-based
+      const SourceFile: string = ''; // can be empty ''
+      SrcLine: integer = 1; // 1-based
+      SrcCol: integer = 0; // 0-based
+      const Name: String = ''): TSourceMapSegment; virtual;
+    property AddMonotonous: boolean read FAddMonotonous
+      write FAddMonotonous default true;// true = AddMapping GeneratedLine/Col must be behind last add, false = check all adds for duplicate
+    function CreateMappings: String; virtual;
+    function ToJSON: TJSONObject; virtual;
+    procedure SaveToStream(aStream: TStream); virtual;
+    procedure SaveToFile(Filename: string); virtual;
+    function ToString: string; override;
+    property GeneratedFilename: string read FGeneratedFilename write SetGeneratedFilename;
+    function IndexOfName(const Name: string; AddIfNotExists: boolean = false): integer;
+    function IndexOfSourceFile(const SrcFile: string; AddIfNotExists: boolean = false): integer;
+    function Count: integer;
+    property Items[Index: integer]: TSourceMapSegment read GetItems; default; // segments
+    function SourceCount: integer;
+    property SourceRoot: string read FSourceRoot write FSourceRoot;
+    property SourceFiles[Index: integer]: String read GetSourceFiles;
+    property SourceContents[Index: integer]: String read GetSourceContents write SetSourceContents;
+    function NameCount: integer;
+    property Names[Index: integer]: string read GetNames;
+    property Version: integer read FVersion; // 3
+    property Header: String read FHeader write FHeader; // DefaultSrcMapHeader
+  end;
+
+function EncodeBase64VLQ(i: NativeInt): String; // base64 Variable Length Quantity
+function DecodeBase64VLQ(const s: string): NativeInt; // base64 Variable Length Quantity
+function DecodeBase64VLQ(var p: PChar): NativeInt; // base64 Variable Length Quantity
+
+implementation
+
+function EncodeBase64VLQ(i: NativeInt): String;
+{ Convert signed number to base64-VLQ:
+  Each base64 has 6bit, where the most significant bit is the continuation bit
+  (1=there is a next base64 character).
+  The first character contains the 5 least significant bits of the number.
+  The last bit of the first character is the sign bit (1=negative).
+  For example:
+  A = 0 = %000000 => 0
+  B = 1 = %000001 => -0
+  C = 2 = %000010 => 1
+  iF = 34 5 = %100010 %000101 = 00010 00101 = 1000101 = 69
+}
+
+  procedure RaiseRange;
+  begin
+    raise ERangeError.Create('EncodeBase64VLQ');
+  end;
+
+var
+  digits: NativeInt;
+begin
+  Result:='';
+  if i<0 then
+    begin
+    i:=-i;
+    if i>(High(NativeInt)-1) shr 1 then
+      RaiseRange;
+    i:=(i shl 1)+1;
+    end
+  else
+    begin
+    if i>High(NativeInt) shr 1 then
+      RaiseRange;
+    i:=i shl 1;
+    end;
+  repeat
+    digits:=i and %11111;
+    i:=i shr 5;
+    if i>0 then
+      inc(digits,%100000); // need another char -> set continuation bit
+    Result:=Result+Base64Chars[digits+1];
+  until i=0;
+end;
+
+function DecodeBase64VLQ(const s: string): NativeInt;
+var
+  p: PChar;
+begin
+  if s='' then
+    raise EConvertError.Create('DecodeBase64VLQ empty');
+  p:=PChar(s);
+  Result:=DecodeBase64VLQ(p);
+  if p-PChar(s)<>length(s) then
+    raise EConvertError.Create('DecodeBase64VLQ waste');
+end;
+
+function DecodeBase64VLQ(var p: PChar): NativeInt;
+{ Convert base64-VLQ to signed number,
+  For the fomat see EncodeBase64VLQ
+}
+
+  procedure RaiseInvalid;
+  begin
+    raise ERangeError.Create('DecodeBase64VLQ');
+  end;
+
+const
+  MaxShift = 63-5; // actually log2(High(NativeInt))-5
+var
+  c: Char;
+  digit, Shift: Integer;
+begin
+  Result:=0;
+  Shift:=0;
+  repeat
+    c:=p^;
+    case c of
+    'A'..'Z': digit:=ord(c)-ord('A');
+    'a'..'z': digit:=ord(c)-ord('a')+26;
+    '0'..'9': digit:=ord(c)-ord('0')+52;
+    '+': digit:=62;
+    '/': digit:=63;
+    else RaiseInvalid;
+    end;
+    inc(p);
+    if Shift>MaxShift then
+      RaiseInvalid;
+    inc(Result,(digit and %11111) shl Shift);
+    inc(Shift,5);
+  until digit<%100000;
+  if (Result and 1)>0 then
+    Result:=-(Result shr 1)
+  else
+    Result:=Result shr 1;
+end;
+
+{ TSourceMap.TStringToIndex }
+
+constructor TSourceMap.TStringToIndex.Create;
+begin
+  FItems:=TFPHashList.Create;
+end;
+
+destructor TSourceMap.TStringToIndex.Destroy;
+begin
+  FItems.Clear;
+  FreeAndNil(FItems);
+  inherited Destroy;
+end;
+
+procedure TSourceMap.TStringToIndex.Clear;
+begin
+  FItems.Clear;
+end;
+
+procedure TSourceMap.TStringToIndex.Add(const Value: String; Index: integer);
+begin
+  // Note: nil=0 means not found in TFPHashList
+  FItems.Add(Value,{%H-}Pointer(PtrInt(Index+1)));
+end;
+
+function TSourceMap.TStringToIndex.FindValue(const Value: String
+  ): integer;
+begin
+  // Note: nil=0 means not found in TFPHashList
+  Result:=integer({%H-}PtrInt(FItems.Find(Value)))-1;
+end;
+
+{ TSourceMap }
+
+procedure TSourceMap.SetGeneratedFilename(const AValue: string);
+begin
+  if FGeneratedFilename=AValue then Exit;
+  FGeneratedFilename:=AValue;
+end;
+
+procedure TSourceMap.SetSourceContents(Index: integer; const AValue: String);
+begin
+  TSourceMapSrc(FSources[Index]).Source:=AValue;
+end;
+
+function TSourceMap.GetItems(Index: integer): TSourceMapSegment;
+begin
+  Result:=TSourceMapSegment(FItems[Index]);
+end;
+
+function TSourceMap.GetSourceContents(Index: integer): String;
+begin
+  Result:=TSourceMapSrc(FSources[Index]).Source;
+end;
+
+function TSourceMap.GetNames(Index: integer): string;
+begin
+  Result:=FNames[Index];
+end;
+
+function TSourceMap.GetSourceFiles(Index: integer): String;
+begin
+  Result:=TSourceMapSrc(FSources[Index]).Filename;
+end;
+
+constructor TSourceMap.Create(const aGeneratedFilename: string);
+begin
+  FVersion:=3;
+  FNames:=TStringList.Create;
+  FNameToIndex:=TStringToIndex.Create;
+  FItems:=TFPList.Create;
+  FSources:=TFPList.Create;
+  FSourceToIndex:=TStringToIndex.Create;
+  FAddMonotonous:=true;
+  FHeader:=DefaultSrcMapHeader;
+  GeneratedFilename:=aGeneratedFilename;
+end;
+
+destructor TSourceMap.Destroy;
+begin
+  Clear;
+  FreeAndNil(FSourceToIndex);
+  FreeAndNil(FSources);
+  FreeAndNil(FItems);
+  FreeAndNil(FNameToIndex);
+  FreeAndNil(FNames);
+  inherited Destroy;
+end;
+
+procedure TSourceMap.Clear;
+var
+  i: Integer;
+begin
+  FSourceToIndex.Clear;
+  for i:=0 to FSources.Count-1 do
+    TObject(FSources[i]).Free;
+  FSources.Clear;
+  for i:=0 to FItems.Count-1 do
+    TObject(FItems[i]).Free;
+  FItems.Clear;
+  FNameToIndex.Clear;
+  FNames.Clear;
+end;
+
+function TSourceMap.AddMapping(GeneratedLine: integer; GeneratedCol: integer;
+  const SourceFile: string; SrcLine: integer; SrcCol: integer;
+  const Name: String): TSourceMapSegment;
+
+  procedure RaiseInvalid(Msg: string);
+  begin
+    raise Exception.CreateFmt('%s (GeneratedLine=%d GeneratedCol=%d SrcFile="%s" SrcLine=%d SrcCol=%d Name="%s")',
+      [Msg,GeneratedLine,GeneratedCol,SourceFile,SrcLine,SrcCol,Name]);
+  end;
+
+var
+  NodeCnt, i: Integer;
+  OtherNode: TSourceMapSegment;
+begin
+  if GeneratedLine<1 then
+    RaiseInvalid('invalid GeneratedLine');
+  if GeneratedCol<0 then
+    RaiseInvalid('invalid GeneratedCol');
+  if SourceFile='' then
+    begin
+    if Count=0 then
+      RaiseInvalid('missing source file');
+    if SrcLine<>1 then
+      RaiseInvalid('invalid SrcLine');
+    if SrcCol<>0 then
+      RaiseInvalid('invalid SrcCol');
+    if Name<>'' then
+      RaiseInvalid('invalid Name');
+    end
+  else
+    begin
+    if SrcLine<1 then
+      RaiseInvalid('invalid SrcLine');
+    if SrcCol<0 then
+      RaiseInvalid('invalid SrcCol');
+    end;
+
+  // check if generated line/col already exists
+  NodeCnt:=Count;
+  if AddMonotonous then
+    begin
+    if NodeCnt>0 then
+      begin
+      OtherNode:=Items[NodeCnt-1];
+      if (OtherNode.GeneratedLine>GeneratedLine)
+          or ((OtherNode.GeneratedLine=GeneratedLine)
+            and (OtherNode.GeneratedColumn>GeneratedCol)) then
+        RaiseInvalid('GeneratedLine/Col not monotonous');
+      // Note: same line/col is allowed
+      end;
+    end
+  else
+    begin
+    for i:=0 to NodeCnt-1 do
+      begin
+      OtherNode:=Items[i];
+      if (OtherNode.GeneratedLine=GeneratedLine) and (OtherNode.GeneratedColumn=GeneratedCol) then
+        RaiseInvalid('duplicate GeneratedLine/Col');
+      end;
+    end;
+
+  // add
+  Result:=TSourceMapSegment.Create;
+  Result.Index:=FItems.Count;
+  Result.GeneratedLine:=GeneratedLine;
+  Result.GeneratedColumn:=GeneratedCol;
+  if SourceFile='' then
+    Result.SrcFileIndex:=-1
+  else
+    Result.SrcFileIndex:=IndexOfSourceFile(SourceFile,true);
+  Result.SrcLine:=SrcLine;
+  Result.SrcColumn:=SrcCol;
+  if Name<>'' then
+    Result.NameIndex:=IndexOfName(Name,true)
+  else
+    Result.NameIndex:=-1;
+  FItems.Add(Result);
+end;
+
+function TSourceMap.CreateMappings: String;
+
+  procedure Add(ms: TMemoryStream; const s: string);
+  begin
+    if s<>'' then
+      ms.Write(s[1],length(s));
+  end;
+
+var
+  ms: TMemoryStream;
+  i, LastGeneratedLine, LastGeneratedColumn, j, LastSrcFileIndex, LastSrcLine,
+    LastSrcColumn, SrcLine, LastNameIndex: Integer;
+  Item: TSourceMapSegment;
+begin
+  Result:='';
+  LastGeneratedLine:=1;
+  LastGeneratedColumn:=0;
+  LastSrcFileIndex:=0;
+  LastSrcLine:=0;
+  LastSrcColumn:=0;
+  LastNameIndex:=0;
+  ms:=TMemoryStream.Create;
+  try
+    for i:=0 to Count-1 do
+      begin
+      Item:=Items[i];
+      if LastGeneratedLine<Item.GeneratedLine then
+        begin
+        // new line
+        LastGeneratedColumn:=0;
+        for j:=LastGeneratedLine+1 to Item.GeneratedLine do
+          ms.WriteByte(ord(';'));
+        LastGeneratedLine:=Item.GeneratedLine;
+        end
+      else if i>0 then
+        begin
+        // not the first segment
+        if (LastGeneratedLine=Item.GeneratedLine)
+            and (LastGeneratedColumn=Item.GeneratedColumn) then
+          continue;
+        ms.WriteByte(ord(','));
+        end;
+      // column diff
+      Add(ms,EncodeBase64VLQ(Item.GeneratedColumn-LastGeneratedColumn));
+      LastGeneratedColumn:=Item.GeneratedColumn;
+
+      if Item.SrcFileIndex<0 then
+        continue; // no source -> segment length 1
+      // src file index diff
+      Add(ms,EncodeBase64VLQ(Item.SrcFileIndex-LastSrcFileIndex));
+      LastSrcFileIndex:=Item.SrcFileIndex;
+      // src line diff
+      SrcLine:=Item.SrcLine-1; // 0 based in version 3
+      Add(ms,EncodeBase64VLQ(SrcLine-LastSrcLine));
+      LastSrcLine:=SrcLine;
+      // src column diff
+      Add(ms,EncodeBase64VLQ(Item.SrcColumn-LastSrcColumn));
+      LastSrcColumn:=Item.SrcColumn;
+      // name index
+      if Item.NameIndex<0 then
+        continue; // no name -> segment length 4
+      Add(ms,EncodeBase64VLQ(Item.NameIndex-LastNameIndex));
+      LastNameIndex:=Item.NameIndex;
+      end;
+    SetLength(Result,ms.Size);
+    if Result<>'' then
+      Move(ms.Memory^,Result[1],ms.Size);
+  finally
+    ms.Free;
+  end;
+end;
+
+function TSourceMap.ToJSON: TJSONObject;
+var
+  Obj: TJSONObject;
+  i: Integer;
+  Arr: TJSONArray;
+  Mappings: String;
+begin
+  Result:=nil;
+  Mappings:=CreateMappings;
+
+  Obj:=TJSONObject.Create;
+  try
+    // "version" - integer
+    Obj.Add('version',Version);
+
+    // "file" - GeneratedFilename
+    if GeneratedFilename<>'' then
+      Obj.Add('file',GeneratedFilename);
+
+    // "sourceRoot" - SourceRoot
+    if SourceRoot<>'' then
+      Obj.Add('sourceRoot',SourceRoot);
+
+    // "sources" - array of filenames
+    Arr:=TJSONArray.Create;
+    Obj.Add('sources',Arr);
+    for i:=0 to SourceCount-1 do
+      Arr.Add(SourceFiles[i]);
+
+    // "sourcesContent" - array of source content: null or source as string
+    // only needed if there is a source
+    i:=SourceCount-1;
+    while i>=0 do
+      if SourceContents[i]='' then
+        dec(i)
+      else
+        begin
+        // there is a source -> add array
+        Arr:=TJSONArray.Create;
+        Obj.Add('sourcesContent',Arr);
+        for i:=0 to SourceCount-1 do
+          if SourceContents[i]='' then
+            Arr.Add(TJSONNull.Create)
+          else
+            Arr.Add(SourceContents[i]);
+        break;
+        end;
+
+    // "names" - array of names
+    Arr:=TJSONArray.Create;
+    Obj.Add('names',Arr);
+    for i:=0 to NameCount-1 do
+      Arr.Add(Names[i]);
+
+    // "mappings" - string
+    Obj.Add('mappings',Mappings);
+
+    Result:=Obj;
+  finally
+    if Result=nil then
+      Obj.Free;
+  end;
+end;
+
+procedure TSourceMap.SaveToStream(aStream: TStream);
+var
+  Obj: TJSONObject;
+begin
+  Obj:=ToJSON;
+  try
+    if Header<>'' then
+      aStream.Write(Header[1],length(Header));
+    Obj.DumpJSON(aStream);
+  finally
+    Obj.Free;
+  end;
+end;
+
+procedure TSourceMap.SaveToFile(Filename: string);
+var
+  TheStream: TMemoryStream;
+begin
+  TheStream:=TMemoryStream.Create;
+  try
+    SaveToStream(TheStream);
+    TheStream.Position:=0;
+    TheStream.SaveToFile(Filename);
+  finally
+    TheStream.Free;
+  end;
+end;
+
+function TSourceMap.ToString: string;
+var
+  Obj: TJSONObject;
+begin
+  Obj:=ToJSON;
+  try
+    Result:=Header+Obj.AsJSON;
+  finally
+    Obj.Free;
+  end;
+end;
+
+function TSourceMap.IndexOfName(const Name: string; AddIfNotExists: boolean
+  ): integer;
+begin
+  Result:=FNameToIndex.FindValue(Name);
+  if (Result>=0) or not AddIfNotExists then exit;
+  Result:=FNames.Count;
+  FNames.Add(Name);
+  FNameToIndex.Add(Name,Result);
+end;
+
+function TSourceMap.IndexOfSourceFile(const SrcFile: string;
+  AddIfNotExists: boolean): integer;
+var
+  Src: TSourceMapSrc;
+begin
+  Result:=FSourceToIndex.FindValue(SrcFile);
+  if (Result>=0) or not AddIfNotExists then exit;
+  Src:=TSourceMapSrc.Create;
+  Src.Filename:=SrcFile;
+  Result:=FSources.Count;
+  FSources.Add(Src);
+  FSourceToIndex.Add(SrcFile,Result);
+end;
+
+function TSourceMap.Count: integer;
+begin
+  Result:=FItems.Count;
+end;
+
+function TSourceMap.SourceCount: integer;
+begin
+  Result:=FSources.Count;
+end;
+
+function TSourceMap.NameCount: integer;
+begin
+  Result:=FNames.Count;
+end;
+
+end.
+

packages/fcl-js/src/jstoken.pp

@@ -1,3 +1,17 @@
+{ ********************************************************************* 
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2016 Michael Van Canneyt.
+       
+    Javascript token definitions
+            
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+                   
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+                                
+  **********************************************************************}
 unit jstoken;
 
 {$mode objfpc}{$H+}
@@ -8,7 +22,7 @@ type
 
   TJSToken = (tjsUnknown,
      // Specials
-     tjsEOF,tjsWhiteSpace,tjsChar,tjsString, tjsIdentifier,tjsNumber, tjsComment,tjsREGEX, tjsRESERVED,
+     tjsEOF,tjsWhiteSpace,tjsChar,tjsString{this bites TJSString}, tjsIdentifier,tjsNumber, tjsComment,tjsREGEX, tjsRESERVED,
      tjsANDAND, tjsANDEQ,
      tjsBraceOpen,tjsBraceClose,tjsSQuaredBraceOpen,tjsSQuaredBraceClose,tjsCurlyBraceOpen,tjsCurlyBraceClose,
      tjsCOMMA,tjsCOLON,  tjsDOT,tjsSEMICOLON, tjsASSIGN,tjsGT,tjsLT, tjsConditional,

packages/fcl-js/tests/tcparser.pp

@@ -5,7 +5,7 @@ unit tcparser;
 interface
 
 uses
-  Classes, SysUtils, fpcunit, testutils, testregistry, jsParser, jstree, jsbase;
+  Classes, SysUtils, fpcunit, testregistry, jsParser, jstree, jsbase;
 
 type
 
@@ -172,9 +172,6 @@ Function TTestJSParser.GetFirstStatement: TJSElement;
 
 Var
   E : TJSElementNodes;
-  N : TJSElement;
-  X : TJSExpressionStatement;
-
 begin
   E:=GetStatements;
   AssertNotNull('Have statements',E);
@@ -186,8 +183,6 @@ end;
 Function TTestJSParser.GetFirstVar: TJSElement;
 Var
   E : TJSElementNodes;
-  N : TJSElement;
-  X : TJSExpressionStatement;
 begin
   E:=GetVars;
   AssertNotNull('Have statements',E);
@@ -202,8 +197,6 @@ Function TTestJSParser.GetExpressionStatement: TJSExpressionStatement;
 
 Var
   N : TJSElement;
-  X : TJSExpressionStatement;
-
 begin
   N:=GetFirstStatement;
   CheckClass(N,TJSExpressionStatement);
@@ -2247,8 +2240,6 @@ procedure TTestJSParser.TestSwitchEmpty;
 Var
   E : TJSElement;
   S : TJSSwitchStatement;
-  P : TJSPrimaryExpressionIdent;
-
 begin
   CreateParser('switch (a) {}');
   E:=GetFirstStatement;
@@ -2265,7 +2256,6 @@ procedure TTestJSParser.TestSwitchOne;
 Var
   E : TJSElement;
   S : TJSSwitchStatement;
-  P : TJSPrimaryExpressionIdent;
   C : TJSCaseElement;
 begin
   CreateParser('switch (a) { case c : {}}');
@@ -2286,7 +2276,6 @@ procedure TTestJSParser.TestSwitchTwo;
 Var
   E : TJSElement;
   S : TJSSwitchStatement;
-  P : TJSPrimaryExpressionIdent;
   C : TJSCaseElement;
 begin
   CreateParser('switch (a) { case c: {}'+sLineBreak+' case d: {}}');
@@ -2310,7 +2299,6 @@ procedure TTestJSParser.TestSwitchTwoDefault;
 Var
   E : TJSElement;
   S : TJSSwitchStatement;
-  P : TJSPrimaryExpressionIdent;
   C : TJSCaseElement;
 begin
   CreateParser('switch (a) { case c: {} case d: {} default: {}}');