* synchronised with fixes_3_0 till r31136

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

.gitattributes

@@ -2003,6 +2003,8 @@ packages/fcl-base/src/blowfish.pp svneol=native#text/plain
 packages/fcl-base/src/bufstream.pp svneol=native#text/plain
 packages/fcl-base/src/cachecls.pp svneol=native#text/plain
 packages/fcl-base/src/contnrs.pp svneol=native#text/plain
+packages/fcl-base/src/csvdocument.pp svneol=native#text/plain
+packages/fcl-base/src/csvreadwrite.pp svneol=native#text/plain
 packages/fcl-base/src/custapp.pp svneol=native#text/plain
 packages/fcl-base/src/dummy/eventlog.inc svneol=native#text/plain
 packages/fcl-base/src/eventlog.pp svneol=native#text/plain
@@ -2066,6 +2068,7 @@ packages/fcl-db/src/base/Makefile svneol=native#text/plain
 packages/fcl-db/src/base/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/src/base/bufdataset.pas svneol=native#text/plain
 packages/fcl-db/src/base/bufdataset_parser.pp svneol=native#text/plain
+packages/fcl-db/src/base/csvdataset.pp svneol=native#text/plain
 packages/fcl-db/src/base/database.inc svneol=native#text/plain
 packages/fcl-db/src/base/dataset.inc svneol=native#text/plain
 packages/fcl-db/src/base/datasource.inc svneol=native#text/plain
@@ -2279,6 +2282,8 @@ packages/fcl-db/tests/memdstoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/reruntest.sh svneol=native#text/plain
 packages/fcl-db/tests/sdfdstoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/sqldbtoolsunit.pas svneol=native#text/plain
+packages/fcl-db/tests/sqlite3dstoolsunit.pas svneol=LF#text/plain eol=lf
+packages/fcl-db/tests/tccsvdataset.pp svneol=native#text/plain
 packages/fcl-db/tests/tcgensql.pas svneol=native#text/plain
 packages/fcl-db/tests/tcparser.pas svneol=native#text/plain
 packages/fcl-db/tests/tcsdfdata.pp svneol=native#text/plain
@@ -2540,6 +2545,9 @@ packages/fcl-process/Makefile svneol=native#text/plain
 packages/fcl-process/Makefile.fpc svneol=native#text/plain
 packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/fcl-process/fpmake.pp svneol=native#text/plain
+packages/fcl-process/src/amicommon/pipes.inc svneol=native#text/plain
+packages/fcl-process/src/amicommon/process.inc svneol=native#text/plain
+packages/fcl-process/src/amicommon/simpleipc.inc svneol=native#text/plain
 packages/fcl-process/src/dbugintf.pp svneol=native#text/plain
 packages/fcl-process/src/dbugmsg.pp svneol=native#text/plain
 packages/fcl-process/src/dummy/pipes.inc svneol=native#text/plain
@@ -3112,6 +3120,7 @@ packages/fcl-web/src/base/Makefile svneol=native#text/plain
 packages/fcl-web/src/base/Makefile.fpc svneol=native#text/plain
 packages/fcl-web/src/base/README.txt svneol=native#text/plain
 packages/fcl-web/src/base/cgiapp.pp svneol=native#text/plain
+packages/fcl-web/src/base/cgiprotocol.pp svneol=native#text/plain
 packages/fcl-web/src/base/custcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/custfcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/custhttpapp.pp svneol=native#text/plain
@@ -3129,10 +3138,18 @@ packages/fcl-web/src/base/fphttpapp.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpclient.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpstatus.pas svneol=native#text/plain
+packages/fcl-web/src/base/fphttpwebclient.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpjwt.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpoauth2.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpoauth2ini.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
+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/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/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
@@ -3200,6 +3217,8 @@ packages/fcl-xml/tests/readertest.pp svneol=native#text/plain
 packages/fcl-xml/tests/readerunit.pp svneol=native#text/plain
 packages/fcl-xml/tests/template.xml svneol=native#text/plain
 packages/fcl-xml/tests/testgen.pp svneol=native#text/plain
+packages/fcl-xml/tests/testxmlconf.lpi svneol=native#text/plain
+packages/fcl-xml/tests/testxmlconf.lpr svneol=native#text/plain
 packages/fcl-xml/tests/xmlts.pp svneol=native#text/plain
 packages/fcl-xml/tests/xpathts.pp svneol=native#text/plain
 packages/fftw/Makefile svneol=native#text/plain
@@ -6712,7 +6731,6 @@ packages/rtl-extra/src/linux/unixsock.inc svneol=native#text/plain
 packages/rtl-extra/src/linux/unixsockets.inc svneol=native#text/plain
 packages/rtl-extra/src/linux/unixsocketsh.inc svneol=native#text/plain
 packages/rtl-extra/src/linux/unxsockh.inc svneol=native#text/plain
-packages/rtl-extra/src/morphos/sockets.pp svneol=native#text/plain
 packages/rtl-extra/src/msdos/printer.pp svneol=native#text/plain
 packages/rtl-extra/src/netbsd/unixsock.inc svneol=native#text/plain
 packages/rtl-extra/src/netbsd/unxsockh.inc svneol=native#text/plain
@@ -7506,6 +7524,7 @@ packages/winunits-base/src/richedit.pp svneol=native#text/plain
 packages/winunits-base/src/shellapi.pp svneol=native#text/plain
 packages/winunits-base/src/shfolder.pp svneol=native#text/plain
 packages/winunits-base/src/shlobj.pp svneol=native#text/plain
+packages/winunits-base/src/shlwapi.pp svneol=native#text/plain
 packages/winunits-base/src/stdole2.pas svneol=native#text/plain
 packages/winunits-base/src/tmschema.inc svneol=native#text/plain
 packages/winunits-base/src/typelib.pas svneol=native#text/plain
@@ -7906,6 +7925,7 @@ rtl/aix/termiosproc.inc svneol=native#text/plain
 rtl/aix/unxconst.inc svneol=native#text/plain
 rtl/aix/unxfunc.inc svneol=native#text/plain
 rtl/amicommon/README.TXT svneol=native#text/plain
+rtl/amicommon/athreads.pp svneol=native#text/plain
 rtl/amicommon/classes.pp svneol=native#text/plain
 rtl/amicommon/dos.pp svneol=native#text/plain
 rtl/amicommon/osdebug.inc svneol=native#text/plain
@@ -7917,12 +7937,14 @@ rtl/amicommon/sysheap.inc svneol=native#text/plain
 rtl/amicommon/sysos.inc svneol=native#text/plain
 rtl/amicommon/sysosh.inc svneol=native#text/plain
 rtl/amicommon/sysutils.pp svneol=native#text/plain
+rtl/amicommon/tthread.inc svneol=native#text/plain
 rtl/amiga/Makefile svneol=native#text/plain
 rtl/amiga/Makefile.fpc svneol=native#text/plain
 rtl/amiga/doslibd.inc svneol=native#text/plain
 rtl/amiga/m68k/doslibf.inc svneol=native#text/plain
 rtl/amiga/m68k/execd.inc svneol=native#text/plain
 rtl/amiga/m68k/execf.inc svneol=native#text/plain
+rtl/amiga/m68k/m68kamiga.inc svneol=native#text/plain
 rtl/amiga/m68k/prt0.as svneol=native#text/plain
 rtl/amiga/m68k/utild1.inc svneol=native#text/plain
 rtl/amiga/m68k/utild2.inc svneol=native#text/plain
@@ -7936,7 +7958,6 @@ rtl/amiga/powerpc/utild2.inc svneol=native#text/plain
 rtl/amiga/powerpc/utilf.inc svneol=native#text/plain
 rtl/amiga/system.pp svneol=native#text/plain
 rtl/amiga/timerd.inc svneol=native#text/plain
-rtl/amiga/tthread.inc svneol=native#text/plain
 rtl/android/Makefile svneol=native#text/plain
 rtl/android/Makefile.fpc svneol=native#text/plain
 rtl/android/arm/dllprt0.as svneol=native#text/plain
@@ -7970,7 +7991,6 @@ rtl/arm/thumb.inc svneol=native#text/plain
 rtl/arm/thumb2.inc svneol=native#text/plain
 rtl/aros/Makefile svneol=native#text/plain
 rtl/aros/Makefile.fpc svneol=native#text/plain
-rtl/aros/arosthreads.inc svneol=native#text/plain
 rtl/aros/doslibd.inc svneol=native#text/plain
 rtl/aros/i386/doslibf.inc svneol=native#text/plain
 rtl/aros/i386/execd.inc svneol=native#text/plain
@@ -7980,10 +8000,7 @@ rtl/aros/i386/utild1.inc svneol=native#text/plain
 rtl/aros/i386/utild2.inc svneol=native#text/plain
 rtl/aros/i386/utilf.inc svneol=native#text/plain
 rtl/aros/system.pp svneol=native#text/plain
-rtl/aros/systemthreadh.inc svneol=native#text/plain
-rtl/aros/systhrd.inc svneol=native#text/plain
 rtl/aros/timerd.inc svneol=native#text/plain
-rtl/aros/tthread.inc svneol=native#text/plain
 rtl/atari/Makefile svneol=native#text/plain
 rtl/atari/Makefile.fpc svneol=native#text/plain
 rtl/atari/prt0.as svneol=native#text/plain
@@ -8717,11 +8734,9 @@ rtl/morphos/emuld.inc svneol=native#text/plain
 rtl/morphos/execd.inc svneol=native#text/plain
 rtl/morphos/execf.inc svneol=native#text/plain
 rtl/morphos/prt0.as svneol=native#text/plain
-rtl/morphos/sysosh.inc svneol=native#text/plain
 rtl/morphos/system.pp svneol=native#text/plain
 rtl/morphos/timerd.inc svneol=native#text/plain
 rtl/morphos/timerf.inc svneol=native#text/plain
-rtl/morphos/tthread.inc svneol=native#text/plain
 rtl/morphos/utild1.inc svneol=native#text/plain
 rtl/morphos/utild2.inc svneol=native#text/plain
 rtl/morphos/utilf.inc svneol=native#text/plain
@@ -9395,6 +9410,7 @@ rtl/win32/winsysut.pp svneol=native#text/plain
 rtl/win32/wprt0.as svneol=native#text/plain
 rtl/win64/Makefile svneol=native#text/plain
 rtl/win64/Makefile.fpc svneol=native#text/plain
+rtl/win64/buildrtl.lpi svneol=native#text/plain
 rtl/win64/buildrtl.pp svneol=native#text/plain
 rtl/win64/classes.pp svneol=native#text/plain
 rtl/win64/rtldefs.inc svneol=native#text/plain
@@ -10396,6 +10412,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/tb205.pp svneol=native#text/plain
+tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tbs0594.pp svneol=native#text/pascal
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
@@ -14261,10 +14278,13 @@ tests/webtbs/tw2729.pp svneol=native#text/plain
 tests/webtbs/tw27294.pp svneol=native#text/plain
 tests/webtbs/tw2730.pp svneol=native#text/plain
 tests/webtbs/tw2731.pp svneol=native#text/plain
+tests/webtbs/tw27320.pp svneol=native#text/pascal
+tests/webtbs/tw27348.pp svneol=native#text/pascal
 tests/webtbs/tw2736.pp svneol=native#text/plain
 tests/webtbs/tw2737.pp svneol=native#text/plain
 tests/webtbs/tw2738.pp svneol=native#text/plain
 tests/webtbs/tw2739.pp svneol=native#text/plain
+tests/webtbs/tw27424.pp svneol=native#text/pascal
 tests/webtbs/tw2758.pp svneol=native#text/plain
 tests/webtbs/tw2763.pp svneol=native#text/plain
 tests/webtbs/tw2765.pp svneol=native#text/plain
@@ -14276,16 +14296,19 @@ tests/webtbs/tw2776.pp svneol=native#text/plain
 tests/webtbs/tw2778.pp svneol=native#text/plain
 tests/webtbs/tw2779.pp svneol=native#text/plain
 tests/webtbs/tw2780.pp svneol=native#text/plain
+tests/webtbs/tw27832.pp svneol=native#text/plain
 tests/webtbs/tw2788.pp svneol=native#text/plain
 tests/webtbs/tw2789.pp svneol=native#text/plain
 tests/webtbs/tw2794.pp svneol=native#text/plain
 tests/webtbs/tw2803.pp svneol=native#text/plain
 tests/webtbs/tw2806.pp svneol=native#text/plain
 tests/webtbs/tw2807.pp svneol=native#text/plain
+tests/webtbs/tw28089.pp svneol=native#text/plain
 tests/webtbs/tw2809.pp svneol=native#text/plain
 tests/webtbs/tw2812.pp svneol=native#text/plain
 tests/webtbs/tw2815.pp svneol=native#text/plain
 tests/webtbs/tw2817.pp svneol=native#text/plain
+tests/webtbs/tw28271.pp svneol=native#text/pascal
 tests/webtbs/tw2829.pp svneol=native#text/plain
 tests/webtbs/tw2830.pp svneol=native#text/plain
 tests/webtbs/tw2832.pp svneol=native#text/plain
@@ -15005,6 +15028,7 @@ tests/webtbs/uw2706a.pp svneol=native#text/plain
 tests/webtbs/uw2706b.pp svneol=native#text/plain
 tests/webtbs/uw27294.pp svneol=native#text/plain
 tests/webtbs/uw2731.pp svneol=native#text/plain
+tests/webtbs/uw27320.defaults.pp svneol=native#text/pascal
 tests/webtbs/uw2738.pp svneol=native#text/plain
 tests/webtbs/uw2834.pp svneol=native#text/plain
 tests/webtbs/uw2920.pp svneol=native#text/plain
@@ -15326,8 +15350,8 @@ utils/h2pas/h2pyacclib.pas svneol=native#text/plain
 utils/h2pas/scan.l svneol=native#text/plain
 utils/h2pas/scan.pas svneol=native#text/plain
 utils/h2pas/testit.h -text
-utils/h2pas/yylex.cod -text
-utils/h2pas/yyparse.cod -text
+utils/h2pas/yylex.cod svneol=native#text/plain
+utils/h2pas/yyparse.cod svneol=native#text/plain
 utils/importtl/Makefile svneol=native#text/plain
 utils/importtl/Makefile.fpc svneol=native#text/plain
 utils/importtl/Makefile.fpc.fpcmake svneol=native#text/plain
@@ -15375,6 +15399,7 @@ utils/javapp/src/fpc/tools/javapp/StackMapTableData.java svneol=native#text/plai
 utils/javapp/src/fpc/tools/javapp/Tables.java svneol=native#text/plain
 utils/javapp/src/fpc/tools/javapp/TrapData.java svneol=native#text/plain
 utils/javapp/src/fpc/tools/javapp/TypeSignature.java svneol=native#text/plain
+utils/mkinsadd.pp svneol=native#text/plain
 utils/mksymbian/Makefile svneol=native#text/plain
 utils/mksymbian/Makefile.fpc svneol=native#text/plain
 utils/mksymbian/Makefile.fpc.fpcmake svneol=native#text/plain

compiler/pgenutil.pas

@@ -1128,7 +1128,11 @@ uses
               firstidx:=result.count;
 
               constraintdata.free;
-            end;
+            end
+          else
+            if token=_SEMICOLON then
+              { a semicolon terminates a type parameter group }
+              firstidx:=result.count;
         until not (try_to_consume(_COMMA) or try_to_consume(_SEMICOLON));
         block_type:=old_block_type;
       end;

compiler/rautils.pas

@@ -1211,7 +1211,7 @@ Begin
          begin
            if tconstsym(srsym).consttyp=constord then
             Begin
-              l:=tconstsym(srsym).value.valueord.svalue;
+              l:=aint(tconstsym(srsym).value.valueord.svalue);
               SearchIConstant:=TRUE;
               exit;
             end;

compiler/symdef.pas

@@ -1244,8 +1244,12 @@ implementation
                        crc:=UpdateCrc32(crc,hs[1],length(hs));
                      end;
                  end;
-               hs:=hp.vardef.mangledparaname;
-               crc:=UpdateCrc32(crc,hs[1],length(hs));
+               if not is_void(tprocdef(st.defowner).returndef) then
+                 begin
+                   { add a little prefix so that x(integer; integer) is different from x(integer):integer }
+                   hs:='$$'+tprocdef(st.defowner).returndef.mangledparaname;
+                   crc:=UpdateCrc32(crc,hs[1],length(hs));
+                 end;
                s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
              end;
            if prefix<>'' then
@@ -3418,8 +3422,10 @@ implementation
 
     constructor tarraydef.create_from_pointer(def:tpointerdef);
       begin
-         { use -1 so that the elecount will not overflow }
-         self.create(0,high(asizeint)-1,ptrsinttype);
+         { divide by the element size and do -1 so the array will have a valid size,
+           further, the element size might be 0 e.g. for empty records, so use max(...,1)
+           to avoid a division by zero }
+         self.create(0,(high(asizeint) div max(def.pointeddef.size,1))-1,ptrsinttype);
          arrayoptions:=[ado_IsConvertedPointer];
          setelementdef(def.pointeddef);
       end;
@@ -5508,8 +5514,12 @@ implementation
                     crc:=UpdateCrc32(crc,hs[1],length(hs));
                   end;
               end;
-            hs:=hp.vardef.mangledparaname;
-            crc:=UpdateCrc32(crc,hs[1],length(hs));
+            if not is_void(returndef) then
+              begin
+                { add a little prefix so that x(integer; integer) is different from x(integer):integer }
+                hs:='$$'+returndef.mangledparaname;
+                crc:=UpdateCrc32(crc,hs[1],length(hs));
+              end;
             defaultmangledname:=Copy(defaultmangledname,1,oldlen)+'$crc'+hexstr(crc,8);
           end;
       end;

compiler/systems/i_amiga.pas

@@ -34,7 +34,7 @@ unit i_amiga;
             system       : system_m68k_Amiga;
             name         : 'Commodore Amiga';
             shortname    : 'amiga';
-            flags        : [tf_files_case_aware];
+            flags        : [tf_files_case_aware,tf_has_winlike_resources];
             cpu          : cpu_m68k;
             unit_env     : '';
             extradefines : 'HASAMIGA';
@@ -47,7 +47,7 @@ unit i_amiga;
             asmext       : '.s';
             objext       : '.o';
             resext       : '.res';
-            resobjext    : '.or';
+            resobjext    : '.fpcres'; { Because 68k Amiga uses external resources for now }
             sharedlibext : '.library';
             staticlibext : '.a';
             staticlibprefix : 'libp';
@@ -66,7 +66,7 @@ unit i_amiga;
             link         : ld_none;
             linkextern   : ld_amiga;
             ar           : ar_gnu_ar;
-            res          : res_none;
+            res          : res_ext;
             dbg          : dbg_stabs;
             script       : script_amiga;
             endian       : endian_big;

compiler/systems/i_morph.pas

@@ -34,7 +34,7 @@ unit i_morph;
             system       : system_powerpc_MorphOS;
             name         : 'MorphOS';
             shortname    : 'MorphOS';
-            flags        : [tf_files_case_aware,tf_smartlink_library];
+            flags        : [tf_files_case_aware,tf_smartlink_library,tf_has_winlike_resources];
             cpu          : cpu_powerpc;
             unit_env     : '';
             extradefines : 'HASAMIGA';

compiler/systems/t_amiga.pas

@@ -27,7 +27,7 @@ unit t_amiga;
 interface
 
     uses
-      link;
+      rescmn, comprsrc, link;
 
 
 type
@@ -277,9 +277,9 @@ end;
 
 initialization
 {$ifdef m68k}
-{ TODO: No executable creation support for m68k yet!}
   RegisterLinker(ld_amiga,TLinkerAmiga);
   RegisterTarget(system_m68k_Amiga_info);
+  RegisterRes(res_ext_info, TWinLikeResourceFile);
 {$endif m68k}
 {$ifdef powerpc}
   RegisterLinker(ld_amiga,TLinkerAmiga);

ide/fputils.pas

@@ -157,8 +157,12 @@ begin
             else
              FixFileName[i]:=s[i];
  {$else}
+ {$ifndef hasamiga}
       '/' : FixFileName[i]:='\';
  'A'..'Z' : FixFileName[i]:=char(byte(s[i])+32);
+ {$else}
+      '\' : FixFileName[i]:='/';
+ {$endif}
  {$endif}
      else
       FixFileName[i]:=s[i];

packages/amunits/examples/bezier.pas

@@ -35,7 +35,7 @@ Program Bezier;
    [email protected]
 }
 
-uses exec, intuition, agraphics, utility,pastoc, systemvartags;
+uses exec, intuition, agraphics, utility, systemvartags;
 
 type
     PointRec = packed Record
@@ -249,9 +249,9 @@ begin
 
     rp := w^.RPort;
     GfxMove(rp, 252, 30);
-    GfxText(rp, pas2c('Enter points by pressing the left mouse button'), 46);
+    GfxText(rp, 'Enter points by pressing the left mouse button', 46);
     GfxMove(rp, 252, 40);
-    GfxText(rp, pas2c('Double click on the last point to begin drawing'), 47);
+    GfxText(rp, 'Double click on the last point to begin drawing', 47);
     repeat
         GetPoints;  { Both these routines will quit if }
         DrawBezier; { the window is closed. }

packages/amunits/examples/bezier2.pas

@@ -1,4 +1,4 @@
-Program Bezier;
+Program Bezier2;
 
 
 {  This program draws Bezier curves in the slow, simple, recursive
@@ -26,7 +26,7 @@ Program Bezier;
    [email protected]
 }
 
-uses exec, intuition, agraphics, utility, pastoc, systemvartags;
+uses exec, intuition, agraphics, utility, systemvartags;
 
 type
     PointRec = Record

packages/amunits/src/coreunits/agraphics.pas

@@ -89,7 +89,7 @@ type
         x,y     : Word;
     end;
 
-    PLANEPTR = Pointer;
+    TPLANEPTR = PByte;
 
     pBitMap = ^tBitMap;
     tBitMap = record
@@ -98,7 +98,7 @@ type
         Flags           : Byte;
         Depth           : Byte;
         pad             : Word;
-        Planes          : Array [0..7] of PLANEPTR;
+        Planes          : Array [0..7] of TPLANEPTR;
     end;
 {* flags for AllocBitMap, etc. *}
 const
@@ -2242,7 +2242,7 @@ PROCEDURE AddFont(textFont : pTextFont location 'a1'); syscall GfxBase 480;
 PROCEDURE AddVSprite(vSprite : pVSprite location 'a0'; rp : pRastPort location 'a1'); syscall GfxBase 102;
 FUNCTION AllocBitMap(sizex : ULONG location 'd0'; sizey : ULONG location 'd1'; depth : ULONG location 'd2'; flags : ULONG location 'd3'; const friend_bitmap : pBitMap location 'a0') : pBitMap; syscall GfxBase 918;
 FUNCTION AllocDBufInfo(vp : pViewPort location 'a0') : pDBufInfo; syscall GfxBase 966;
-FUNCTION AllocRaster(width : ULONG location 'd0'; height : ULONG location 'd1') : pCHAR; syscall GfxBase 492;
+FUNCTION AllocRaster(width : ULONG location 'd0'; height : ULONG location 'd1') : TPlanePtr; syscall GfxBase 492;
 FUNCTION AllocSpriteDataA(const bm : pBitMap location 'a2';const tags : pTagItem location 'a1') : pExtSprite; syscall GfxBase 1020;
 PROCEDURE AndRectRegion(region : pRegion location 'a0';const rectangle : pRectangle location 'a1'); syscall GfxBase 504;
 FUNCTION AndRegionRegion(const srcRegion : pRegion location 'a0'; destRegion : pRegion location 'a1') : LongBool; syscall GfxBase 624;
@@ -2262,7 +2262,7 @@ PROCEDURE BltBitMapRastPort(const srcBitMap : pBitMap location 'a0'; xSrc : LONG
 PROCEDURE BltClear(memBlock : pCHAR location 'a1'; byteCount : ULONG location 'd0'; flags : ULONG location 'd1'); syscall GfxBase 300;
 PROCEDURE BltMaskBitMapRastPort(const srcBitMap : pBitMap location 'a0'; xSrc : LONGINT location 'd0'; ySrc : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'; minterm : ULONG location 'd6';const bltMask : pCHAR location 'a2'); syscall GfxBase 636;
 PROCEDURE BltPattern(rp : pRastPort location 'a1';const mask : pCHAR location 'a0'; xMin : LONGINT location 'd0'; yMin : LONGINT location 'd1'; xMax : LONGINT location 'd2'; yMax : LONGINT location 'd3'; maskBPR : ULONG location 'd4'); syscall GfxBase 312;
-PROCEDURE BltTemplate(const source : pCHAR location 'a0'; xSrc : LONGINT location 'd0'; srcMod : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'); syscall GfxBase 036;
+PROCEDURE BltTemplate(const source : pWORD location 'a0'; xSrc : LONGINT location 'd0'; srcMod : LONGINT location 'd1'; destRP : pRastPort location 'a1'; xDest : LONGINT location 'd2'; yDest : LONGINT location 'd3'; xSize : LONGINT location 'd4'; ySize : LONGINT location 'd5'); syscall GfxBase 036;
 FUNCTION CalcIVG(v : pView location 'a0'; vp : pViewPort location 'a1') : WORD; syscall GfxBase 828;
 PROCEDURE CBump(copList : pUCopList location 'a1'); syscall GfxBase 366;
 FUNCTION ChangeExtSpriteA(vp : pViewPort location 'a0'; oldsprite : pExtSprite location 'a1'; newsprite : pExtSprite location 'a2';const tags : pTagItem location 'a3') : LONGINT; syscall GfxBase 1026;
@@ -2297,7 +2297,7 @@ PROCEDURE FreeCopList(copList : pCopList location 'a0'); syscall GfxBase 546;
 PROCEDURE FreeCprList(cprList : pcprlist location 'a0'); syscall GfxBase 564;
 PROCEDURE FreeDBufInfo(dbi : pDBufInfo location 'a1'); syscall GfxBase 972;
 PROCEDURE FreeGBuffers(anOb : pAnimOb location 'a0'; rp : pRastPort location 'a1'; flag : LONGINT location 'd0'); syscall GfxBase 600;
-PROCEDURE FreeRaster(p : pCHAR location 'a0'; width : ULONG location 'd0'; height : ULONG location 'd1'); syscall GfxBase 498;
+PROCEDURE FreeRaster(p : TPlanePtr location 'a0'; width : ULONG location 'd0'; height : ULONG location 'd1'); syscall GfxBase 498;
 PROCEDURE FreeSprite(num : LONGINT location 'd0'); syscall GfxBase 414;
 PROCEDURE FreeSpriteData(sp : pExtSprite location 'a2'); syscall GfxBase 1032;
 PROCEDURE FreeVPortCopLists(vp : pViewPort location 'a0'); syscall GfxBase 540;
@@ -2325,7 +2325,7 @@ PROCEDURE InitGels(head : pVSprite location 'a0'; tail : pVSprite location 'a1';
 PROCEDURE InitGMasks(anOb : pAnimOb location 'a0'); syscall GfxBase 174;
 PROCEDURE InitMasks(vSprite : pVSprite location 'a0'); syscall GfxBase 126;
 PROCEDURE InitRastPort(rp : pRastPort location 'a1'); syscall GfxBase 198;
-FUNCTION InitTmpRas(tmpRas : pTmpRas location 'a0'; buffer : PLANEPTR location 'a1'; size : LONGINT location 'd0') : pTmpRas; syscall GfxBase 468;
+FUNCTION InitTmpRas(tmpRas : pTmpRas location 'a0'; buffer : Pointer location 'a1'; size : LONGINT location 'd0') : pTmpRas; syscall GfxBase 468;
 PROCEDURE InitView(view : pView location 'a1'); syscall GfxBase 360;
 PROCEDURE InitVPort(vp : pViewPort location 'a0'); syscall GfxBase 204;
 PROCEDURE LoadRGB32(vp : pViewPort location 'a0';const table : pULONG location 'a1'); syscall GfxBase 882;

packages/amunits/src/coreunits/amigados.pas

@@ -1598,7 +1598,7 @@ FUNCTION CreateProc(const name : pCHAR location 'd1'; pri : LONGINT location 'd2
 FUNCTION CurrentDir(lock : LONGINT location 'd1') : LONGINT; syscall _DOSBase 126;
 PROCEDURE DateStamp(date : pDateStamp location 'd1'); syscall _DOSBase 192;
 FUNCTION DateToStr(datetime : pDateTime location 'd1') : LongBool; syscall _DOSBase 744;
-FUNCTION DeleteFile(const name : pCHAR location 'd1') : LongBool; syscall _DOSBase 072;
+FUNCTION DOSDeleteFile(const name : pCHAR location 'd1') : LongBool; syscall _DOSBase 072;
 FUNCTION DeleteVar(const name : pCHAR location 'd1'; flags : ULONG location 'd2') : LongBool; syscall _DOSBase 912;
 FUNCTION DeviceProc(const name : pCHAR location 'd1') : pMsgPort; syscall _DOSBase 174;
 FUNCTION DoPkt(port : pMsgPort location 'd1'; action : LONGINT location 'd2'; arg1 : LONGINT location 'd3'; arg2 : LONGINT location 'd4'; arg3 : LONGINT location 'd5'; arg4 : LONGINT location 'd6'; arg5 : LONGINT location 'd7') : LONGINT; syscall _DOSBase 240;
@@ -1702,7 +1702,7 @@ FUNCTION SameLock(lock1 : LONGINT location 'd1'; lock2 : LONGINT location 'd2')
 FUNCTION SelectInput(fh : LONGINT location 'd1') : LONGINT; syscall _DOSBase 294;
 FUNCTION SelectOutput(fh : LONGINT location 'd1') : LONGINT; syscall _DOSBase 300;
 PROCEDURE SendPkt(dp : pDosPacket location 'd1'; port : pMsgPort location 'd2'; replyport : pMsgPort location 'd3'); syscall _DOSBase 246;
-FUNCTION SetArgStr(const string_ : pCHAR location 'd1') : LongBool; syscall _DOSBase 540;
+FUNCTION SetArgStr(const string_ : pCHAR location 'd1') : PChar; syscall _DOSBase 540;
 FUNCTION SetComment(const name : pCHAR location 'd1';const comment : pCHAR location 'd2') : LongBool; syscall _DOSBase 180;
 FUNCTION SetConsoleTask(const task : pMsgPort location 'd1') : pMsgPort; syscall _DOSBase 516;
 FUNCTION SetCurrentDirName(const name : pCHAR location 'd1') : LongBool; syscall _DOSBase 558;
@@ -1743,9 +1743,7 @@ FUNCTION MKBADDR(adr: Pointer): BPTR;
 { overlay function and procedures}
 
 FUNCTION AddBuffers(const name : string; number : LONGINT) : BOOLEAN;
-FUNCTION AddPart(dirname : string;const filename : pCHAR; size : ULONG) : BOOLEAN;
 FUNCTION AddPart(dirname : pCHAR;const filename : string; size : ULONG) : BOOLEAN;
-FUNCTION AddPart(dirname : string;const filename : string; size : ULONG) : BOOLEAN;
 FUNCTION AssignAdd(const name : string; lock : LONGINT) : BOOLEAN;
 FUNCTION AssignLate(const name : string;const path : pCHAR) : BOOLEAN;
 FUNCTION AssignLate(const name : pChar;const path : string) : BOOLEAN;
@@ -1755,8 +1753,7 @@ FUNCTION AssignPath(const name : string; const path : pCHAR) : BOOLEAN;
 FUNCTION AssignPath(const name : pCHAR;const path : string) : BOOLEAN;
 FUNCTION AssignPath(const name : string;const path : string) : BOOLEAN;
 FUNCTION CreateDir(const name : string) : LONGINT;
-FUNCTION CreateProc(const name : string; pri : LONGINT; segList : LONGINT; stackSize : LONGINT) : pMsgPort;
-FUNCTION DeleteFile(const name : string) : BOOLEAN;
+FUNCTION DOSDeleteFile(const name : string) : BOOLEAN;
 FUNCTION DeleteVar(const name : string; flags : ULONG) : BOOLEAN;
 FUNCTION DeviceProc(const name : string) : pMsgPort;
 FUNCTION DOSOpen(const name : string; accessMode : LONGINT) : LONGINT;
@@ -1785,26 +1782,20 @@ FUNCTION Lock(const name : string; type_ : LONGINT) : LONGINT;
 FUNCTION MakeDosEntry(const name : string; type_ : LONGINT) : pDosList;
 FUNCTION MakeLink(const name : string; dest : LONGINT; soft : LONGINT) : BOOLEAN;
 FUNCTION MatchFirst(const pat : string; anchor : pAnchorPath) : LONGINT;
-FUNCTION MatchPattern(const pat : string; str : pCHAR) : BOOLEAN;
 FUNCTION MatchPattern(const pat : pCHAR; str : string) : BOOLEAN;
-FUNCTION MatchPattern(const pat : string; str : string) : BOOLEAN;
-FUNCTION MatchPatternNoCase(const pat : string; str : pCHAR) : BOOLEAN;
 FUNCTION MatchPatternNoCase(const pat : pCHAR; str : string) : BOOLEAN;
-FUNCTION MatchPatternNoCase(const pat : string; str : string) : BOOLEAN;
 FUNCTION NewLoadSeg(const file_ : string;const tags : pTagItem) : LONGINT;
 FUNCTION NewLoadSegTagList(const file_ : string;const tags : pTagItem) : LONGINT;
 FUNCTION PathPart(const path : string) : pCHAR;
 FUNCTION PrintFault(code : LONGINT;const header : string) : BOOLEAN;
 FUNCTION PutStr(const str : string) : BOOLEAN;
 FUNCTION ReadArgs(const arg_template : string; arra : pLONGINT; args : pRDArgs) : pRDArgs;
-FUNCTION ReadItem(const name : string; maxchars : LONGINT; cSource : pCSource) : LONGINT;
 FUNCTION ReadLink(port : pMsgPort; lock : LONGINT;const path : string; buffer : pCHAR; size : ULONG) : BOOLEAN;
 FUNCTION Relabel(const drive : string;const newname : pCHAR) : BOOLEAN;
 FUNCTION Relabel(const drive : pCHAR;const newname : string) : BOOLEAN;
 FUNCTION Relabel(const drive : string;const newname : string) : BOOLEAN;
 FUNCTION RemAssignList(const name : string; lock : LONGINT) : BOOLEAN;
 FUNCTION RunCommand(seg : LONGINT; stack : LONGINT;const paramptr : string; paramlen : LONGINT) : LONGINT;
-FUNCTION SetArgStr(const string_ : string) : BOOLEAN;
 FUNCTION SetComment(const name : string;const comment : pCHAR) : BOOLEAN;
 FUNCTION SetComment(const name : pCHAR;const comment : string) : BOOLEAN;
 FUNCTION SetComment(const name : string;const comment : string) : BOOLEAN;
@@ -1822,401 +1813,355 @@ FUNCTION DOSSystem(const command : string;const tags : pTagItem) : LONGINT;
 
 IMPLEMENTATION
 
-uses pastoc;
 
-FUNCTION BADDR(bval : BPTR): POINTER;
+FUNCTION BADDR(bval : BPTR): POINTER; inline;
 BEGIN
     BADDR := POINTER( bval shl 2);
 END;
 
-FUNCTION MKBADDR(adr : POINTER): BPTR;
+FUNCTION MKBADDR(adr : POINTER): BPTR; inline;
 BEGIN
     MKBADDR := BPTR( LONGINT(adr) shr 2);
 END;
 
 FUNCTION AddBuffers(const name : string; number : LONGINT) : BOOLEAN;
 begin
-     AddBuffers := AddBuffers(pas2c(name), number);
+     AddBuffers := AddBuffers(PChar(RawByteString(name)), number);
 end;
 
-FUNCTION AddPart(dirname : string;const filename : pCHAR; size : ULONG) : BOOLEAN;
+FUNCTION AddPart(dirname : pCHAR; const filename : string; size : ULONG) : BOOLEAN;
 begin
-     AddPart := AddPart(pas2c(dirname),filename,size);
-end;
-
-FUNCTION AddPart(dirname : pCHAR;const filename : string; size : ULONG) : BOOLEAN;
-begin
-     AddPart := AddPart(dirname,pas2c(filename),size);
-end;
-
-FUNCTION AddPart(dirname : string;const filename : string; size : ULONG) : BOOLEAN;
-begin
-     AddPart := AddPart(pas2c(dirname),pas2c(filename),size);
+     AddPart := AddPart(dirname,PChar(RawByteString(filename)),size);
 end;
 
 FUNCTION AssignAdd(const name : string; lock : LONGINT) : BOOLEAN;
 begin
-     AssignAdd := AssignAdd(pas2c(name),lock);
+     AssignAdd := AssignAdd(PChar(RawByteString(name)),lock);
 end;
 
 FUNCTION AssignLate(const name : string;const path : pCHAR) : BOOLEAN;
 begin
-     AssignLate := AssignLate(pas2c(name),path);
+     AssignLate := AssignLate(PChar(RawByteString(name)),path);
 end;
 
 FUNCTION AssignLate(const name : pChar;const  path : string) : BOOLEAN;
 begin
-     AssignLate := AssignLate(name,pas2c(path));
+     AssignLate := AssignLate(name,PChar(RawByteString(path)));
 end;
 
 FUNCTION AssignLate(const name : string;const path : string) : BOOLEAN;
 begin
-     AssignLate := AssignLate(pas2c(name),pas2c(path));
+     AssignLate := AssignLate(PChar(RawByteString(name)),PChar(RawByteString(path)));
 end;
 
 FUNCTION AssignLock(const name : string; lock : LONGINT) : BOOLEAN;
 begin
-     AssignLock := AssignLock(pas2c(name),lock);
+     AssignLock := AssignLock(PChar(RawByteString(name)),lock);
 end;
 
 FUNCTION AssignPath(const name : string;const path : pCHAR) : BOOLEAN;
 begin
-     AssignPath := AssignPath(pas2c(name),path);
+     AssignPath := AssignPath(PChar(RawByteString(name)),path);
 end;
 
 FUNCTION AssignPath(const name : pCHAR;const path : string) : BOOLEAN;
 begin
-     AssignPath := AssignPath(name,pas2c(path));
+     AssignPath := AssignPath(name,PChar(RawByteString(path)));
 end;
 
 FUNCTION AssignPath(const name : string;const path : string) : BOOLEAN;
 begin
-     AssignPath := AssignPath(pas2c(name),pas2c(path));
+     AssignPath := AssignPath(PChar(RawByteString(name)),PChar(RawByteString(path)));
 end;
 
 FUNCTION CreateDir(const name : string) : LONGINT;
 begin
-     CreateDir := CreateDir(pas2c(name));
+     CreateDir := CreateDir(PChar(RawByteString(name)));
 end;
 
-FUNCTION CreateProc(const name : string; pri : LONGINT; segList : LONGINT; stackSize : LONGINT) : pMsgPort;
+FUNCTION DOSDeleteFile(const name : string) : BOOLEAN;
 begin
-     CreateProc := CreateProc(pas2c(name),pri,segList,stackSize);
-end;
-
-FUNCTION DeleteFile(const name : string) : BOOLEAN;
-begin
-     DeleteFile := DeleteFile(pas2c(name));
+     DOSDeleteFile := DOSDeleteFile(PChar(RawByteString(name)));
 end;
 
 FUNCTION DeleteVar(const name : string; flags : ULONG) : BOOLEAN;
 begin
-     DeleteVar := DeleteVar(pas2c(name),flags);
+     DeleteVar := DeleteVar(PChar(RawByteString(name)),flags);
 end;
 
 FUNCTION DeviceProc(const name : string) : pMsgPort;
 begin
-     Deviceproc := DeviceProc(pas2c(name));
+     Deviceproc := DeviceProc(PChar(RawByteString(name)));
 end;
 
 FUNCTION DOSOpen(const name : string; accessMode : LONGINT) : LONGINT;
 begin
-     DOSOpen := DOSOpen(pas2c(name),accessMode);
+     DOSOpen := DOSOpen(PChar(RawByteString(name)),accessMode);
 end;
 
 FUNCTION DOSRename(const oldName : string;const newName : pCHAR) : Boolean;
 begin
-     DOSRename := DOSRename(pas2c(oldName),newName);
+     DOSRename := DOSRename(PChar(RawByteString(oldName)),newName);
 end;
 
 FUNCTION DOSRename(const oldName : pCHAR;const newName : string) : Boolean;
 begin
-     DOSRename := DOSRename(oldName,pas2c(newName));
+     DOSRename := DOSRename(oldName,PChar(RawByteString(newName)));
 end;
 
 FUNCTION DOSRename(const oldName : string;const newName : string) : Boolean;
 begin
-     DOSRename := DOSRename(pas2c(oldName),pas2c(newName));
+     DOSRename := DOSRename(PChar(RawByteString(oldName)),PChar(RawByteString(newName)));
 end;
 
 FUNCTION Execute(const string_ : string; file_ : LONGINT; file2 : LONGINT) : BOOLEAN;
 begin
-     Execute := Execute(pas2c(string_),file_ ,file2);
+     Execute := Execute(PChar(RawByteString(string_)),file_ ,file2);
 end;
 
 FUNCTION Fault(code : LONGINT; header : string; buffer : pCHAR; len : LONGINT) : BOOLEAN;
 begin
-    Fault := Fault(code,pas2c(header),buffer,len);
+    Fault := Fault(code,PChar(RawByteString(header)),buffer,len);
 end;
 
 FUNCTION FilePart(const path : string) : pCHAR;
 begin
-    FilePart := FilePart(pas2c(path));
+    FilePart := FilePart(PChar(RawByteString(path)));
 end;
 
 FUNCTION FindArg(const keyword : string;const arg_template : pCHAR) : LONGINT;
 begin
-    FindArg := FindArg(pas2c(keyword),arg_template);
+    FindArg := FindArg(PChar(RawByteString(keyword)),arg_template);
 end;
 
 FUNCTION FindArg(const keyword : pCHAR;const arg_template : string) : LONGINT;
 begin
-    FindArg := FindArg(keyword,pas2c(arg_template));
+    FindArg := FindArg(keyword,PChar(RawByteString(arg_template)));
 end;
 
 FUNCTION FindArg(const keyword : string;const arg_template : string) : LONGINT;
 begin
-    FindArg := FindArg(pas2c(keyword),pas2c(arg_template));
+    FindArg := FindArg(PChar(RawByteString(keyword)),PChar(RawByteString(arg_template)));
 end;
 
 FUNCTION FindDosEntry(const dlist : pDosList;const name : string; flags : ULONG) : pDosList;
 begin
-    FindDosEntry := FindDosEntry(dlist,pas2c(name),flags);
+    FindDosEntry := FindDosEntry(dlist,PChar(RawByteString(name)),flags);
 end;
 
 FUNCTION FindSegment(const name : string;const seg : pSegment; system : LONGINT) : pSegment;
 begin
-    FindSegment := FindSegment(pas2c(name),seg,system);
+    FindSegment := FindSegment(PChar(RawByteString(name)),seg,system);
 end;
 
 FUNCTION FindVar(const name : string; type_ : ULONG) : pLocalVar;
 begin
-    FindVar := FindVar(pas2c(name),type_);
+    FindVar := FindVar(PChar(RawByteString(name)),type_);
 end;
 
 FUNCTION Format(const filesystem : string;const volumename : pCHAR; dostype : ULONG) : BOOLEAN;
 begin
-    Format := Format(pas2c(filesystem),volumename,dostype);
+    Format := Format(PChar(RawByteString(filesystem)),volumename,dostype);
 end;
 
 FUNCTION Format(const filesystem : pCHAR;const volumename : string; dostype : ULONG) : BOOLEAN;
 begin
-    Format := Format(filesystem,pas2c(volumename),dostype);
+    Format := Format(filesystem,PChar(RawByteString(volumename)),dostype);
 end;
 
 FUNCTION Format(const filesystem : string;const volumename : string; dostype : ULONG) : BOOLEAN;
 begin
-    Format := Format(pas2c(filesystem),pas2c(volumename),dostype);
+    Format := Format(PChar(RawByteString(filesystem)),PChar(RawByteString(volumename)),dostype);
 end;
 
 FUNCTION FPuts(fh : LONGINT;const str : string) : BOOLEAN;
 begin
-    FPuts := FPuts(fh,pas2c(str));
+    FPuts := FPuts(fh,PChar(RawByteString(str)));
 end;
 
 FUNCTION GetDeviceProc(const name : string; dp : pDevProc) : pDevProc;
 begin
-    GetDeviceProc := GetDeviceProc(pas2c(name),dp);
+    GetDeviceProc := GetDeviceProc(PChar(RawByteString(name)),dp);
 end;
 
 FUNCTION GetVar(const name : string; buffer : pCHAR; size : LONGINT; flags : LONGINT) : LONGINT;
 begin
-    GetVar := GetVar(pas2c(name),buffer,size,flags);
+    GetVar := GetVar(PChar(RawByteString(name)),buffer,size,flags);
 end;
 
 FUNCTION Inhibit(const name : string; onoff : LONGINT) : BOOLEAN;
 begin
-    Inhibit := Inhibit(pas2c(name),onoff);
+    Inhibit := Inhibit(PChar(RawByteString(name)),onoff);
 end;
 
 FUNCTION IsFileSystem(const name : string) : BOOLEAN;
 begin
-    IsFileSystem := IsFileSystem(pas2c(name));
+    IsFileSystem := IsFileSystem(PChar(RawByteString(name)));
 end;
 
 FUNCTION LoadSeg(const name : string) : LONGINT;
 begin
-    LoadSeg := LoadSeg(pas2c(name));
+    LoadSeg := LoadSeg(PChar(RawByteString(name)));
 end;
 
 FUNCTION Lock(const name : string; type_ : LONGINT) : LONGINT;
 begin
-    Lock := Lock(pas2c(name),type_);
+    Lock := Lock(PChar(RawByteString(name)),type_);
 end;
 
 FUNCTION MakeDosEntry(const name : string; type_ : LONGINT) : pDosList;
 begin
-    MakeDosEntry := MakeDosEntry(pas2c(name),type_);
+    MakeDosEntry := MakeDosEntry(PChar(RawByteString(name)),type_);
 end;
 
 FUNCTION MakeLink(const name : string; dest : LONGINT; soft : LONGINT) : BOOLEAN;
 begin
-    MakeLink := MakeLink(pas2c(name),dest,soft);
+    MakeLink := MakeLink(PChar(RawByteString(name)),dest,soft);
 end;
 
 FUNCTION MatchFirst(const pat : string; anchor : pAnchorPath) : LONGINT;
 begin
-    MatchFirst := MatchFirst(pas2c(pat),anchor);
-end;
-
-FUNCTION MatchPattern(const pat : string; str : pCHAR) : BOOLEAN;
-begin
-    MatchPattern := MatchPattern(pas2c(pat),str);
+    MatchFirst := MatchFirst(PChar(RawByteString(pat)),anchor);
 end;
 
 FUNCTION MatchPattern(const pat : pCHAR; str : string) : BOOLEAN;
 begin
-    MatchPattern := MatchPattern(pat,pas2c(str));
-end;
-
-FUNCTION MatchPattern(const pat : string; str : string) : BOOLEAN;
-begin
-    MatchPattern := MatchPattern(pas2c(pat),pas2c(str));
-end;
-
-FUNCTION MatchPatternNoCase(const pat : string; str : pCHAR) : BOOLEAN;
-begin
-    MatchPatternNoCase := MatchPatternNoCase(pas2c(pat),str);
+    MatchPattern := MatchPattern(pat,PChar(RawByteString(str)));
 end;
 
 FUNCTION MatchPatternNoCase(const pat : pCHAR; str : string) : BOOLEAN;
 begin
-    MatchPatternNoCase := MatchPatternNoCase(pat,pas2c(str));
-end;
-
-FUNCTION MatchPatternNoCase(const pat : string; str : string) : BOOLEAN;
-begin
-    MatchPatternNoCase := MatchPatternNoCase(pas2c(pat),pas2c(str));
+    MatchPatternNoCase := MatchPatternNoCase(pat,PChar(RawByteString(str)));
 end;
 
 FUNCTION NewLoadSeg(const file_ : string;const tags : pTagItem) : LONGINT;
 begin
-    NewLoadSeg := NewLoadSeg(pas2c(file_),tags);
+    NewLoadSeg := NewLoadSeg(PChar(RawByteString(file_)),tags);
 end;
 
 FUNCTION NewLoadSegTagList(const file_ : string;const tags : pTagItem) : LONGINT;
 begin
-    NewLoadSegTagList := NewLoadSegTagList(pas2c(file_),tags);
+    NewLoadSegTagList := NewLoadSegTagList(PChar(RawByteString(file_)),tags);
 end;
 
 FUNCTION PathPart(const path : string) : pCHAR;
 begin
-    PathPart := PathPart(pas2c(path));
+    PathPart := PathPart(PChar(RawByteString(path)));
 end;
 
 FUNCTION PrintFault(code : LONGINT;const header : string) : BOOLEAN;
 begin
-    PrintFault := PrintFault(code,pas2c(header));
+    PrintFault := PrintFault(code,PChar(RawByteString(header)));
 end;
 
 FUNCTION PutStr(const str : string) : BOOLEAN;
 begin
-    PutStr := PutStr(pas2c(str));
+    PutStr := PutStr(PChar(RawByteString(str)));
 end;
 
 FUNCTION ReadArgs(const arg_template : string; arra : pLONGINT; args : pRDArgs) : pRDArgs;
 begin
-    ReadArgs := ReadArgs(pas2c(arg_template),arra,args);
-end;
-
-FUNCTION ReadItem(const name : string; maxchars : LONGINT; cSource : pCSource) : LONGINT;
-begin
-    ReadItem := ReadItem(pas2c(name),maxchars,cSource);
+    ReadArgs := ReadArgs(PChar(RawByteString(arg_template)),arra,args);
 end;
 
 FUNCTION ReadLink(port : pMsgPort; lock : LONGINT;const path : string; buffer : pCHAR; size : ULONG) : BOOLEAN;
 begin
-    ReadLink := ReadLink(port,lock,pas2c(path),buffer,size);
+    ReadLink := ReadLink(port,lock,PChar(RawByteString(path)),buffer,size);
 end;
 
 FUNCTION Relabel(const drive : string;const newname : pCHAR) : BOOLEAN;
 begin
-    Relabel := Relabel(pas2c(drive),newname);
+    Relabel := Relabel(PChar(RawByteString(drive)),newname);
 end;
 
 FUNCTION Relabel(const drive : pCHAR;const newname : string) : BOOLEAN;
 begin
-    Relabel := Relabel(drive,pas2c(newname));
+    Relabel := Relabel(drive,PChar(RawByteString(newname)));
 end;
 
 FUNCTION Relabel(const drive : string;const newname : string) : BOOLEAN;
 begin
-    Relabel := Relabel(pas2c(drive),pas2c(newname));
+    Relabel := Relabel(PChar(RawByteString(drive)),PChar(RawByteString(newname)));
 end;
 
 FUNCTION RemAssignList(const name : string; lock : LONGINT) : BOOLEAN;
 begin
-    RemAssignList := RemAssignList(pas2c(name),lock);
+    RemAssignList := RemAssignList(PChar(RawByteString(name)),lock);
 end;
 
 FUNCTION RunCommand(seg : LONGINT; stack : LONGINT;const paramptr : string; paramlen : LONGINT) : LONGINT;
 begin
-    RunCommand := RunCommand(seg,stack,pas2c(paramptr),paramlen);
-end;
-
-FUNCTION SetArgStr(const string_ : string) : BOOLEAN;
-begin
-    SetArgStr := SetArgStr(pas2c(string_));
+    RunCommand := RunCommand(seg,stack,PChar(RawByteString(paramptr)),paramlen);
 end;
 
 FUNCTION SetComment(const name : string;const comment : pCHAR) : BOOLEAN;
 begin
-    SetComment := SetComment(pas2c(name),comment);
+    SetComment := SetComment(PChar(RawByteString(name)),comment);
 end;
 
 FUNCTION SetComment(const name : pCHAR;const comment : string) : BOOLEAN;
 begin
-    SetComment := SetComment(name,pas2c(comment));
+    SetComment := SetComment(name,PChar(RawByteString(comment)));
 end;
 
 FUNCTION SetComment(const name : string;const comment : string) : BOOLEAN;
 begin
-    SetComment := SetComment(pas2c(name),pas2c(comment));
+    SetComment := SetComment(PChar(RawByteString(name)),PChar(RawByteString(comment)));
 end;
 
 FUNCTION SetCurrentDirName(const name : string) : BOOLEAN;
 begin
-     SetCurrentDirName := SetCurrentDirName(pas2c(name));
+     SetCurrentDirName := SetCurrentDirName(PChar(RawByteString(name)));
 end;
 
 FUNCTION SetFileDate(const name : string; date : pDateStamp) : BOOLEAN;
 begin
-     SetFileDate := SetFileDate(pas2c(name),date);
+     SetFileDate := SetFileDate(PChar(RawByteString(name)),date);
 end;
 
 FUNCTION SetOwner(const name : string; owner_info : LONGINT) : BOOLEAN;
 begin
-     SetOwner := SetOwner(pas2c(name),owner_info);
+     SetOwner := SetOwner(PChar(RawByteString(name)),owner_info);
 end;
 
 FUNCTION SetProgramName(const name : string) : BOOLEAN;
 begin
-     SetProgramName := SetProgramName(pas2c(name));
+     SetProgramName := SetProgramName(PChar(RawByteString(name)));
 end;
 
 FUNCTION SetPrompt(const name : string) : BOOLEAN;
 begin
-     SetPrompt := SetPrompt(pas2c(name));
+     SetPrompt := SetPrompt(PChar(RawByteString(name)));
 end;
 
 FUNCTION SetProtection(const name : string; protect : LONGINT) : BOOLEAN;
 begin
-     SetProtection := SetProtection(pas2c(name),protect);
+     SetProtection := SetProtection(PChar(RawByteString(name)),protect);
 end;
 
 FUNCTION SetVar(const name : string; buffer : pCHAR; size : LONGINT; flags : LONGINT) : BOOLEAN;
 begin
-     SetVar := SetVar(pas2c(name),buffer,size,flags);
+     SetVar := SetVar(PChar(RawByteString(name)),buffer,size,flags);
 end;
 
 FUNCTION SplitName(const name : string; seperator : ULONG; buf : pCHAR; oldpos : LONGINT; size : LONGINT) : smallint;
 begin
-     SplitName := SplitName(pas2c(name), seperator,buf,oldpos,size);
+     SplitName := SplitName(PChar(RawByteString(name)),seperator,buf,oldpos,size);
 end;
 
 FUNCTION StrToLong(const string_ : string; VAR value : LONGINT) : LONGINT;
 begin
-     StrToLong := StrToLong(pas2c(string_),value);
+     StrToLong := StrToLong(PChar(RawByteString(string_)),value);
 end;
 
 FUNCTION SystemTagList(const command : string;const tags : pTagItem) : LONGINT;
 begin
-     SystemTagList := SystemTagList(pas2c(command),tags);
+     SystemTagList := SystemTagList(PChar(RawByteString(command)),tags);
 end;
 
 FUNCTION DOSSystem(const command : string;const tags : pTagItem) : LONGINT;
 begin
-     DOSSystem := DOSSystem(pas2c(command),tags);
+     DOSSystem := DOSSystem(PChar(RawByteString(command)),tags);
 end;
 
 

packages/amunits/src/coreunits/amigalib.pas

@@ -100,6 +100,8 @@ function DoSuperMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
 function CoerceMethodA(cl : pIClass; obj : pObject_; msg : APTR): ulong;
 function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
 
+procedure HookEntry;
+
 {
 
    NAME
@@ -159,13 +161,11 @@ function SetSuperAttrsA(cl : pIClass; obj: pObject_; msg : APTR): ulong;
 
 }
 
-procedure printf(Fmtstr : pchar; Args : array of const);
-procedure printf(Fmtstr : string; Args : array of const);
+procedure printf(Fmtstr : pchar; const Args : array of const);
+procedure printf(Fmtstr : string; const Args : array of const);
 
 IMPLEMENTATION
 
-uses pastoc;
-
 {*  Exec support functions from amiga.lib  *}
 
 procedure BeginIO (ioRequest: pIORequest);
@@ -393,35 +393,49 @@ begin
     SetSuperAttrsA := DoSuperMethodA(cl, obj, @arr);
 end;
 
-var
-  argarray : array [0..20] of longint;
+{ Do *NOT* change this to nostackframe! }
+{ The compiler will build a stackframe with link/unlk. So that will actually correct
+  the stackpointer for both Pascal/StdCall and cdecl functions, so the stackpointer will
+  be correct on exit. It also needs no manual RTS. The argument push order is also
+  correct for both. (KB) }
+procedure HookEntry; assembler; 
+asm
+  move.l a1,-(a7)    // Msg
+  move.l a2,-(a7)    // Obj
+  move.l a0,-(a7)    // PHook
+  move.l 12(a0),a0   // h_SubEntry = Offset 12
+  jsr (a0)           // Call the SubEntry
+end;
 
-function gettheconst(args : array of const): pointer;
+procedure printf(Fmtstr : pchar; const Args : array of const);
 var
-   i : longint;
-
+  i,j : longint;
+  argarray : array of longint;
+  strarray : array of RawByteString;
 begin
-
-    for i := 0 to High(args) do begin
-        case args[i].vtype of
-            vtinteger : argarray[i] := longint(args[i].vinteger);
-            vtpchar   : argarray[i] := longint(args[i].vpchar);
-            vtchar    : argarray[i] := longint(args[i].vchar);
-            vtpointer : argarray[i] := longint(args[i].vpointer);
-            vtstring  : argarray[i] := longint(pas2c(args[i].vstring^));
-        end;
+  SetLength(argarray, length(args));
+  SetLength(strarray, length(args));
+  j:=0;
+  for i := low(args) to High(args) do 
+    begin
+      case args[i].vtype of
+        vtinteger : argarray[i] := longint(args[i].vinteger);
+        vtpchar   : argarray[i] := longint(args[i].vpchar);
+        vtchar    : argarray[i] := longint(args[i].vchar);
+        vtpointer : argarray[i] := longint(args[i].vpointer);
+        vtstring  : begin
+            strarray[j]:=RawByteString(args[i].vstring^);
+            argarray[i]:=longint(PChar(strarray[j]));
+            inc(j);
+          end;
+      end;
     end;
-    gettheconst := @argarray;
-end;
-
-procedure printf(Fmtstr : pchar; Args : array of const);
-begin
-    VPrintf(Fmtstr,gettheconst(Args));
+  VPrintf(Fmtstr,@argarray[0]);
 end;
 
-procedure printf(Fmtstr : string; Args : array of const);
+procedure printf(Fmtstr : string; const Args : array of const);
 begin
-    VPrintf(pas2c(Fmtstr) ,gettheconst(Args));
+  printf(PChar(RawByteString(Fmtstr)), Args);
 end;
 
 

packages/amunits/src/coreunits/exec.pas

@@ -110,7 +110,6 @@ TYPE
        PULONG   = ^longword;
        PAPTR    = ^APTR;
        PLONG    = ^LONG;
-       psmallint = ^smallint;
 
 const
        {There is a problem with boolean
@@ -1307,7 +1306,6 @@ FUNCTION AVL_FindNextNodeByKey(CONST root : pAVLNode location 'a0'; key : POINTE
 FUNCTION AVL_FindFirstNode(CONST root : pAVLNode location 'a0') : pAVLNode; syscall _ExecBase 900;
 FUNCTION AVL_FindLastNode(CONST root : pAVLNode location 'a0') : pAVLNode; syscall _ExecBase 906;
 
-PROCEDURE AddMemList(size : ULONG; attributes : ULONG; pri : LONGINT; base : POINTER; const name : String);
 FUNCTION FindName(list : pList; const name : String) : pNode;
 FUNCTION FindPort(const name : String) : pMsgPort;
 FUNCTION FindResident(const name : String) : pResident;
@@ -1325,73 +1323,71 @@ function IsMsgPortEmpty( mp : pMsgPort): boolean;
 
 IMPLEMENTATION
 
-uses pastoc;
-
-function BitMask(no :shortint): longint;
+function BitMask(no :shortint): longint; inline;
 begin
    BitMask := 1 shl no;
 end;
 
-function IsListEmpty( list : pList): boolean;
+function IsListEmpty( list : pList): boolean; inline;
 begin
      IsListEmpty := list^.lh_TailPred = pnode(list);
 end;
 
-function IsMsgPortEmpty( mp : pMsgPort): boolean;
+function IsMsgPortEmpty( mp : pMsgPort): boolean; inline;
 begin
      with mp^ do
          IsMsgPortEmpty := mp_MsgList.lh_TailPred = pNode(@mp_MsgList);
 end;
 
-PROCEDURE AddMemList(size : ULONG; attributes : ULONG; pri : LONGINT; base : POINTER; const name : String);
-BEGIN
-    AddMemList(size,attributes,pri,base,pas2c(name));
-END;
 FUNCTION FindName(list : pList; const name : String) : pNode;
 BEGIN
-    FindName := FindName(list,pas2c(name));
+    FindName := FindName(list,PChar(RawByteString(name)));
 END;
+
 FUNCTION FindPort(const name : String) : pMsgPort;
 BEGIN
-    FindPort := FindPort(pas2c(name));
+    FindPort := FindPort(PChar(RawByteString(name)));
 END;
+
 FUNCTION FindResident(const name : String) : pResident;
 BEGIN
-    FindResident := FindResident(pas2c(name));
+    FindResident := FindResident(PChar(RawByteString(name)));
 END;
+
 FUNCTION FindSemaphore(const sigSem : String) : pSignalSemaphore;
 BEGIN
-    FindSemaphore := FindSemaphore(pas2c(sigSem));
+    FindSemaphore := FindSemaphore(PChar(RawByteString(sigSem)));
 END;
+
 FUNCTION FindTask(const name : String) : pTask;
 BEGIN
-    FindTask := FindTask(pas2c(name));
+    FindTask := FindTask(PChar(RawByteString(name)));
 END;
+
 FUNCTION OldOpenLibrary(const libName : String) : pLibrary;
 BEGIN
-    OldOpenLibrary := OldOpenLibrary(pas2c(libName));
+    OldOpenLibrary := OldOpenLibrary(PChar(RawByteString(libName)));
 END;
+
 FUNCTION OpenDevice(const devName : String; unite : ULONG; ioRequest : pIORequest;
 flags : ULONG) : shortint;
 BEGIN
-    OpenDevice := OpenDevice(pas2c(devName),unite,ioRequest,flags);
+    OpenDevice := OpenDevice(PChar(RawByteString(devName)),unite,ioRequest,flags);
 END;
+
 FUNCTION OpenLibrary(const libName : String; version : ULONG) : pLibrary;
 BEGIN
-    OpenLibrary := OpenLibrary(pas2c(libName),version);
+    OpenLibrary := OpenLibrary(PChar(RawByteString(libName)),version);
 END;
+
 FUNCTION OpenResource(const resName : String) : POINTER;
 BEGIN
-    OpenResource := OpenResource(pas2c(resName));
+    OpenResource := OpenResource(PChar(RawByteString(resName)));
 END;
+
 function RawDoFmt(const formatString : String;const dataStream : POINTER; putChProc : tPROCEDURE; putChData : POINTER): pointer;
 BEGIN
-    RawDoFmt := RawDoFmt(pas2c(formatString),dataStream,putChProc,putChData);
+    RawDoFmt := RawDoFmt(PChar(RawByteString(formatString)),dataStream,putChProc,putChData);
 END;
 
 END. (* UNIT EXEC *)
-
-
-
-
-

packages/amunits/src/coreunits/intuition.pas

@@ -4211,42 +4211,37 @@ FUNCTION MakeClass(const classID : pCHAR;const superClassID : string;const super
 FUNCTION MakeClass(const classID : string;const superClassID : string;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
 FUNCTION NewObjectA(classPtr : pIClass;const classID : string;const tagList : pTagItem) : POINTER;
 PROCEDURE SetDefaultPubScreen(const name : string);
-PROCEDURE SetWindowTitles(window : pWindow;const windowTitle : string;const screenTitle : pCHAR);
-PROCEDURE SetWindowTitles(window : pWindow;const windowTitle : pCHAR;const screenTitle : string);
-PROCEDURE SetWindowTitles(window : pWindow;const windowTitle : string;const screenTitle : string);
 FUNCTION TimedDisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG; time : ULONG) : BOOLEAN;
 PROCEDURE UnlockPubScreen(const name : string; screen : pScreen);
 
 IMPLEMENTATION
 
-uses pastoc;
-
-function INST_DATA (cl: pIClass; o: p_Object): Pointer;
+function INST_DATA (cl: pIClass; o: p_Object): Pointer; inline;
 begin
     INST_DATA := Pointer(Longint(o) + cl^.cl_InstOffset);
 end;
 
-function SIZEOF_INSTANCE (cl: pIClass): Longint;
+function SIZEOF_INSTANCE (cl: pIClass): Longint; inline;
 begin
     SIZEOF_INSTANCE := cl^.cl_InstOffset + cl^.cl_InstSize + sizeof(t_Object);
 end;
 
-function BASEOBJECT (o: p_Object): Pointer;
+function BASEOBJECT (o: p_Object): Pointer; inline;
 begin
     BASEOBJECT := Pointer(Longint(o) + sizeof(t_Object));
 end;
 
-function _OBJ(o: p_Object): p_Object;
+function _OBJ(o: p_Object): p_Object; inline;
 begin
      _OBJ := p_Object(o);
 END;
 
-function __OBJECT (o: Pointer): p_Object;
+function __OBJECT (o: Pointer): p_Object; inline;
 begin
     __OBJECT := p_Object(Longint(o) - sizeof(t_Object))
 end;
 
-function OCLASS (o: Pointer): pIClass;
+function OCLASS (o: Pointer): pIClass; inline;
 var
     obj: p_Object;
 begin
@@ -4254,22 +4249,22 @@ begin
     OCLASS := obj^.o_Class;
 end;
 
-function SHIFTITEM (n: smallint): word;
+function SHIFTITEM (n: smallint): word; inline;
 begin
     SHIFTITEM := (n and $3f) shl 5
 end;
 
-function SHIFTMENU (n: smallint): word;
+function SHIFTMENU (n: smallint): word; inline;
 begin
     SHIFTMENU := n and $1f
 end;
 
-function SHIFTSUB (n: smallint): word;
+function SHIFTSUB (n: smallint): word; inline;
 begin
     SHIFTSUB := (n and $1f) shl 11
 end;
 
-function FULLMENUNUM (menu, item, sub: smallint): word;
+function FULLMENUNUM (menu, item, sub: smallint): word; inline;
 begin
     FULLMENUNUM := ((sub and $1f) shl 11) or
                     ((item and $3f) shl 5) or
@@ -4283,104 +4278,89 @@ end;
   A/BPen values of the image class objects as well. This can't work
   in pascal, of course! }
 
-function IM_BGPEN (im: pImage): byte;
+function IM_BGPEN (im: pImage): byte; inline;
 begin
     IM_BGPEN := im^.PlaneOnOff;
 end;
 
-function IM_BOX (im: pImage): pIBox;
+function IM_BOX (im: pImage): pIBox; inline;
 begin
     IM_BOX := pIBox(@im^.LeftEdge);
 END;
 
-function IM_FGPEN (im: pImage): byte;
+function IM_FGPEN (im: pImage): byte; inline;
 begin
     IM_FGPEN := im^.PlanePick;
 end;
 
-function GADGET_BOX (g: pGadget): pIBox;
+function GADGET_BOX (g: pGadget): pIBox; inline;
 begin
     GADGET_BOX := pIBox(@g^.LeftEdge);
 end;
 
-function CUSTOM_HOOK (gadget: pGadget): pHook;
+function CUSTOM_HOOK (gadget: pGadget): pHook; inline;
 begin
     CUSTOM_HOOK := pHook(gadget^.MutualExclude);
 end;
 
-function ITEMNUM( n : Word): Word;
+function ITEMNUM( n : Word): Word; inline;
 begin
     ITEMNUM := (n shr 5) and $3F
 end;
 
-function MENUNUM( n : Word): Word;
+function MENUNUM( n : Word): Word; inline;
 begin
     MENUNUM := n and $1f
 end;
 
-function SUBNUM( n : Word): Word;
+function SUBNUM( n : Word): Word; inline;
 begin
     SUBNUM := (n shr 11) and $1f
 end;
 
-FUNCTION DisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG) : BOOLEAN;
+FUNCTION DisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG) : BOOLEAN; inline;
 begin
-      DisplayAlert := DisplayAlert(alertNumber,pas2c(string_),height);
+      DisplayAlert := DisplayAlert(alertNumber,PChar(RawByteString(string_)),height);
 end;
 
-FUNCTION LockPubScreen(const name : string) : pScreen;
+FUNCTION LockPubScreen(const name : string) : pScreen; inline;
 begin
-      LockPubScreen := LockPubScreen(pas2c(name));
+      LockPubScreen := LockPubScreen(PChar(RawByteString(name)));
 end;
 
 FUNCTION MakeClass(const classID : string;const superClassID : pCHAR;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
 begin
-      MakeClass := MakeClass(pas2c(classID),superClassID,superClassPtr,instanceSize,flags);
+      MakeClass := MakeClass(PChar(RawByteString(classID)),superClassID,superClassPtr,instanceSize,flags);
 end;
 
 FUNCTION MakeClass(const classID : pCHAR;const superClassID : string;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
 begin
-      MakeClass := MakeClass(classID,pas2c(superClassID),superClassPtr,instanceSize,flags);
+      MakeClass := MakeClass(classID,PChar(RawByteString(superClassID)),superClassPtr,instanceSize,flags);
 end;
 
 FUNCTION MakeClass(const classID : string;const superClassID : string;const superClassPtr : pIClass; instanceSize : ULONG; flags : ULONG) : pIClass;
 begin
-      MakeClass := MakeClass(pas2c(classID),pas2c(superClassID),superClassPtr,instanceSize,flags);
+      MakeClass := MakeClass(PChar(RawByteString(classID)),PChar(RawByteString(superClassID)),superClassPtr,instanceSize,flags);
 end;
 
 FUNCTION NewObjectA(classPtr : pIClass;const classID : string;const tagList : pTagItem) : POINTER;
 begin
-      NewObjectA := NewObjectA(classPtr,pas2c(classID),taglist);
+      NewObjectA := NewObjectA(classPtr,PChar(RawByteString(classID)),taglist);
 end;
 
 PROCEDURE SetDefaultPubScreen(const name : string);
 begin
-      SetDefaultPubScreen(pas2c(name));
-end;
-
-PROCEDURE SetWindowTitles(window : pWindow;const windowTitle : string;const screenTitle : pCHAR);
-begin
-      SetWindowTitles(window,pas2c(windowTitle),screenTitle);
-end;
-
-PROCEDURE SetWindowTitles(window : pWindow;const windowTitle : pCHAR;const screenTitle : string);
-begin
-      SetWindowTitles(window,windowTitle,pas2c(screenTitle));
-end;
-
-PROCEDURE SetWindowTitles(window : pWindow;const windowTitle : string;const screenTitle : string);
-begin
-      SetWindowTitles(window,pas2c(windowTitle),pas2c(screenTitle));
+      SetDefaultPubScreen(PChar(RawByteString(name)));
 end;
 
 FUNCTION TimedDisplayAlert(alertNumber : ULONG;const string_ : string; height : ULONG; time : ULONG) : BOOLEAN;
 begin
-      TimedDisplayAlert := TimedDisplayAlert(alertNumber,pas2c(string_),height,time);
+      TimedDisplayAlert := TimedDisplayAlert(alertNumber,PChar(RawByteString(string_)),height,time);
 end;
 
 PROCEDURE UnlockPubScreen(const name : string; screen : pScreen);
 begin
-      UnlockPubScreen(pas2c(name),screen);
+      UnlockPubScreen(PChar(RawByteString(name)),screen);
 end;
 
 

packages/amunits/src/coreunits/layers.pas

@@ -32,10 +32,6 @@
     [email protected]
 }
 {$PACKRECORDS 2}
-{$I useamigasmartlink.inc}
-{$ifdef use_amiga_smartlink}
-   {$smartlink on}
-{$endif use_amiga_smartlink}
 
 UNIT layers;
 
@@ -90,38 +86,38 @@ const
 
 VAR LayersBase : pLibrary;
 
-FUNCTION BeginUpdate(l : pLayer) : LONGINT;
-FUNCTION BehindLayer(dummy : LONGINT; layer : pLayer) : LONGINT;
-FUNCTION CreateBehindHookLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; hook : pHook; bm2 : pBitMap) : pLayer;
-FUNCTION CreateBehindLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; bm2 : pBitMap) : pLayer;
-FUNCTION CreateUpfrontHookLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; hook : pHook; bm2 : pBitMap) : pLayer;
-FUNCTION CreateUpfrontLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; bm2 : pBitMap) : pLayer;
-FUNCTION DeleteLayer(dummy : LONGINT; layer : pLayer) : LONGINT;
-PROCEDURE DisposeLayerInfo(li : pLayer_Info);
-PROCEDURE DoHookClipRects(hook : pHook; rport : pRastPort;const rect : pRectangle);
-PROCEDURE EndUpdate(layer : pLayer; flag : ULONG);
-FUNCTION FattenLayerInfo(li : pLayer_Info) : LONGINT;
-PROCEDURE InitLayers(li : pLayer_Info);
-FUNCTION InstallClipRegion(layer : pLayer;const region : pRegion) : pRegion;
-FUNCTION InstallLayerHook(layer : pLayer; hook : pHook) : pHook;
-FUNCTION InstallLayerInfoHook(li : pLayer_Info;const hook : pHook) : pHook;
-PROCEDURE LockLayer(dummy : LONGINT; layer : pLayer);
-PROCEDURE LockLayerInfo(li : pLayer_Info);
-PROCEDURE LockLayers(li : pLayer_Info);
-FUNCTION MoveLayer(dummy : LONGINT; layer : pLayer; dx : LONGINT; dy : LONGINT) : LONGINT;
-FUNCTION MoveLayerInFrontOf(layer_to_move : pLayer; other_layer : pLayer) : LONGINT;
-FUNCTION MoveSizeLayer(layer : pLayer; dx : LONGINT; dy : LONGINT; dw : LONGINT; dh : LONGINT) : LONGINT;
-FUNCTION NewLayerInfo : pLayer_Info;
-PROCEDURE ScrollLayer(dummy : LONGINT; layer : pLayer; dx : LONGINT; dy : LONGINT);
-FUNCTION SizeLayer(dummy : LONGINT; layer : pLayer; dx : LONGINT; dy : LONGINT) : LONGINT;
-PROCEDURE SortLayerCR(layer : pLayer; dx : LONGINT; dy : LONGINT);
-PROCEDURE SwapBitsRastPortClipRect(rp : pRastPort; cr : pClipRect);
-PROCEDURE ThinLayerInfo(li : pLayer_Info);
-PROCEDURE UnlockLayer(layer : pLayer);
-PROCEDURE UnlockLayerInfo(li : pLayer_Info);
-PROCEDURE UnlockLayers(li : pLayer_Info);
-FUNCTION UpfrontLayer(dummy : LONGINT; layer : pLayer) : LONGINT;
-FUNCTION WhichLayer(li : pLayer_Info; x : LONGINT; y : LONGINT) : pLayer;
+FUNCTION BeginUpdate(l : pLayer location 'a0') : LONGINT; syscall LayersBase 078;
+FUNCTION BehindLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1') : LONGINT; syscall LayersBase 054;
+FUNCTION CreateBehindHookLayer(li : pLayer_Info location 'a0'; bm : pBitMap location 'a1'; x0 : LONGINT location 'd0'; y0 : LONGINT location 'd1'; x1 : LONGINT location 'd2'; y1 : LONGINT location 'd3'; flags : LONGINT location 'd4'; hook : pHook location 'a3'; bm2 : pBitMap location 'a2') : pLayer; syscall LayersBase 192;
+FUNCTION CreateBehindLayer(li : pLayer_Info location 'a0'; bm : pBitMap location 'a1'; x0 : LONGINT location 'd0'; y0 : LONGINT location 'd1'; x1 : LONGINT location 'd2'; y1 : LONGINT location 'd3'; flags : LONGINT location 'd4'; bm2 : pBitMap location 'a2') : pLayer; syscall LayersBase 042;
+FUNCTION CreateUpfrontHookLayer(li : pLayer_Info location 'a0'; bm : pBitMap location 'a1'; x0 : LONGINT location 'd0'; y0 : LONGINT location 'd1'; x1 : LONGINT location 'd2'; y1 : LONGINT location 'd3'; flags : LONGINT location 'd4'; hook : pHook location 'a3'; bm2 : pBitMap location 'a2') : pLayer; syscall LayersBase 186;
+FUNCTION CreateUpfrontLayer(li : pLayer_Info location 'a0'; bm : pBitMap location 'a1'; x0 : LONGINT location 'd0'; y0 : LONGINT location 'd1'; x1 : LONGINT location 'd2'; y1 : LONGINT location 'd3'; flags : LONGINT location 'd4'; bm2 : pBitMap location 'a2') : pLayer; syscall LayersBase 036;
+FUNCTION DeleteLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1') : LONGINT; syscall LayersBase 090;
+PROCEDURE DisposeLayerInfo(li : pLayer_Info location 'a0'); syscall LayersBase 150;
+PROCEDURE DoHookClipRects(hook : pHook location 'a0'; rport : pRastPort location 'a1'; const rect : pRectangle location 'a2'); syscall LayersBase 216;
+PROCEDURE EndUpdate(layer : pLayer location 'a0'; flag : ULONG location 'd0'); syscall LayersBase 084;
+FUNCTION FattenLayerInfo(li : pLayer_Info location 'a0') : LONGINT; syscall LayersBase 156;
+PROCEDURE InitLayers(li : pLayer_Info location 'a0'); syscall LayersBase 030;
+FUNCTION InstallClipRegion(layer : pLayer location 'a0';const region : pRegion location 'a1') : pRegion; syscall LayersBase 174;
+FUNCTION InstallLayerHook(layer : pLayer location 'a0'; hook : pHook location 'a1') : pHook; syscall LayersBase 198;
+FUNCTION InstallLayerInfoHook(li : pLayer_Info location 'a0'; const hook : pHook location 'a1') : pHook; syscall LayersBase 204;
+PROCEDURE LockLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1'); syscall LayersBase 096;
+PROCEDURE LockLayerInfo(li : pLayer_Info location 'a0'); syscall LayersBase 120;
+PROCEDURE LockLayers(li : pLayer_Info location 'a0'); syscall LayersBase 108;
+FUNCTION MoveLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1') : LONGINT; syscall LayersBase 060;
+FUNCTION MoveLayerInFrontOf(layer_to_move : pLayer location 'a0'; other_layer : pLayer location 'a1') : LONGINT; syscall LayersBase 168;
+FUNCTION MoveSizeLayer(layer : pLayer location 'a0'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'; dw : LONGINT location 'd2'; dh : LONGINT location 'd3') : LONGINT; syscall LayersBase 180;
+FUNCTION NewLayerInfo : pLayer_Info; syscall LayersBase 144;
+PROCEDURE ScrollLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'); syscall LayersBase 072;
+FUNCTION SizeLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1') : LONGINT; syscall LayersBase 066;
+PROCEDURE SortLayerCR(layer : pLayer location 'a0'; dx : LONGINT location 'd0'; dy : LONGINT location 'd1'); syscall LayersBase 210;
+PROCEDURE SwapBitsRastPortClipRect(rp : pRastPort location 'a0'; cr : pClipRect location 'a1'); syscall LayersBase 126;
+PROCEDURE ThinLayerInfo(li : pLayer_Info location 'a0'); syscall LayersBase 162;
+PROCEDURE UnlockLayer(layer : pLayer location 'a0'); syscall LayersBase 102;
+PROCEDURE UnlockLayerInfo(li : pLayer_Info location 'a0'); syscall LayersBase 138;
+PROCEDURE UnlockLayers(li : pLayer_Info location 'a0'); syscall LayersBase 114;
+FUNCTION UpfrontLayer(dummy : LONGINT location 'a0'; layer : pLayer location 'a1') : LONGINT; syscall LayersBase 048;
+FUNCTION WhichLayer(li : pLayer_Info location 'a0'; x : LONGINT location 'd0'; y : LONGINT location 'd1') : pLayer; syscall LayersBase 132;
 
 {Here we read how to compile this unit}
 {You can remove this include and use a define instead}
@@ -141,434 +137,6 @@ uses
 amsgbox;
 {$endif dont_use_openlib}
 
-FUNCTION BeginUpdate(l : pLayer) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L l,A0
-    MOVEA.L LayersBase,A6
-    JSR -078(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION BehindLayer(dummy : LONGINT; layer : pLayer) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVEA.L LayersBase,A6
-    JSR -054(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION CreateBehindHookLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; hook : pHook; bm2 : pBitMap) : pLayer;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L bm,A1
-    MOVE.L  x0,D0
-    MOVE.L  y0,D1
-    MOVE.L  x1,D2
-    MOVE.L  y1,D3
-    MOVE.L  flags,D4
-    MOVEA.L hook,A3
-    MOVEA.L bm2,A2
-    MOVEA.L LayersBase,A6
-    JSR -192(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION CreateBehindLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; bm2 : pBitMap) : pLayer;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L bm,A1
-    MOVE.L  x0,D0
-    MOVE.L  y0,D1
-    MOVE.L  x1,D2
-    MOVE.L  y1,D3
-    MOVE.L  flags,D4
-    MOVEA.L bm2,A2
-    MOVEA.L LayersBase,A6
-    JSR -042(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION CreateUpfrontHookLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; hook : pHook; bm2 : pBitMap) : pLayer;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L bm,A1
-    MOVE.L  x0,D0
-    MOVE.L  y0,D1
-    MOVE.L  x1,D2
-    MOVE.L  y1,D3
-    MOVE.L  flags,D4
-    MOVEA.L hook,A3
-    MOVEA.L bm2,A2
-    MOVEA.L LayersBase,A6
-    JSR -186(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION CreateUpfrontLayer(li : pLayer_Info; bm : pBitMap; x0 : LONGINT; y0 : LONGINT; x1 : LONGINT; y1 : LONGINT; flags : LONGINT; bm2 : pBitMap) : pLayer;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L bm,A1
-    MOVE.L  x0,D0
-    MOVE.L  y0,D1
-    MOVE.L  x1,D2
-    MOVE.L  y1,D3
-    MOVE.L  flags,D4
-    MOVEA.L bm2,A2
-    MOVEA.L LayersBase,A6
-    JSR -036(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION DeleteLayer(dummy : LONGINT; layer : pLayer) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVEA.L LayersBase,A6
-    JSR -090(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE DisposeLayerInfo(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -150(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE DoHookClipRects(hook : pHook; rport : pRastPort;const rect : pRectangle);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L hook,A0
-    MOVEA.L rport,A1
-    MOVEA.L rect,A2
-    MOVEA.L LayersBase,A6
-    JSR -216(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE EndUpdate(layer : pLayer; flag : ULONG);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer,A0
-    MOVE.L  flag,D0
-    MOVEA.L LayersBase,A6
-    JSR -084(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION FattenLayerInfo(li : pLayer_Info) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -156(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE InitLayers(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -030(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION InstallClipRegion(layer : pLayer;const region : pRegion) : pRegion;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer,A0
-    MOVEA.L region,A1
-    MOVEA.L LayersBase,A6
-    JSR -174(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION InstallLayerHook(layer : pLayer; hook : pHook) : pHook;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer,A0
-    MOVEA.L hook,A1
-    MOVEA.L LayersBase,A6
-    JSR -198(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION InstallLayerInfoHook(li : pLayer_Info;const hook : pHook) : pHook;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L hook,A1
-    MOVEA.L LayersBase,A6
-    JSR -204(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE LockLayer(dummy : LONGINT; layer : pLayer);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVEA.L LayersBase,A6
-    JSR -096(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE LockLayerInfo(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -120(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE LockLayers(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -108(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MoveLayer(dummy : LONGINT; layer : pLayer; dx : LONGINT; dy : LONGINT) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVE.L  dx,D0
-    MOVE.L  dy,D1
-    MOVEA.L LayersBase,A6
-    JSR -060(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MoveLayerInFrontOf(layer_to_move : pLayer; other_layer : pLayer) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer_to_move,A0
-    MOVEA.L other_layer,A1
-    MOVEA.L LayersBase,A6
-    JSR -168(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MoveSizeLayer(layer : pLayer; dx : LONGINT; dy : LONGINT; dw : LONGINT; dh : LONGINT) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer,A0
-    MOVE.L  dx,D0
-    MOVE.L  dy,D1
-    MOVE.L  dw,D2
-    MOVE.L  dh,D3
-    MOVEA.L LayersBase,A6
-    JSR -180(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION NewLayerInfo : pLayer_Info;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L LayersBase,A6
-    JSR -144(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE ScrollLayer(dummy : LONGINT; layer : pLayer; dx : LONGINT; dy : LONGINT);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVE.L  dx,D0
-    MOVE.L  dy,D1
-    MOVEA.L LayersBase,A6
-    JSR -072(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION SizeLayer(dummy : LONGINT; layer : pLayer; dx : LONGINT; dy : LONGINT) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVE.L  dx,D0
-    MOVE.L  dy,D1
-    MOVEA.L LayersBase,A6
-    JSR -066(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE SortLayerCR(layer : pLayer; dx : LONGINT; dy : LONGINT);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer,A0
-    MOVE.L  dx,D0
-    MOVE.L  dy,D1
-    MOVEA.L LayersBase,A6
-    JSR -210(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE SwapBitsRastPortClipRect(rp : pRastPort; cr : pClipRect);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L rp,A0
-    MOVEA.L cr,A1
-    MOVEA.L LayersBase,A6
-    JSR -126(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE ThinLayerInfo(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -162(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE UnlockLayer(layer : pLayer);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L layer,A0
-    MOVEA.L LayersBase,A6
-    JSR -102(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE UnlockLayerInfo(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -138(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE UnlockLayers(li : pLayer_Info);
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVEA.L LayersBase,A6
-    JSR -114(A6)
-    MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION UpfrontLayer(dummy : LONGINT; layer : pLayer) : LONGINT;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L dummy,A0
-    MOVEA.L layer,A1
-    MOVEA.L LayersBase,A6
-    JSR -048(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION WhichLayer(li : pLayer_Info; x : LONGINT; y : LONGINT) : pLayer;
-BEGIN
-  ASM
-    MOVE.L  A6,-(A7)
-    MOVEA.L li,A0
-    MOVE.L  x,D0
-    MOVE.L  y,D1
-    MOVEA.L LayersBase,A6
-    JSR -132(A6)
-    MOVEA.L (A7)+,A6
-    MOVE.L  D0,@RESULT
-  END;
-END;
-
 const
     { Change VERSION and LIBVERSION to proper values }
 

packages/amunits/src/coreunits/rexx.pas

@@ -495,11 +495,6 @@ PROCEDURE LockRexxBase(resource : ULONG location 'd0'); syscall RexxSysBase 450;
 PROCEDURE UnlockRexxBase(resource : ULONG location 'd0'); syscall RexxSysBase 456;
 
 FUNCTION CreateArgstring(const argstring : string; length : ULONG) : pCHAR;
-FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : pCHAR) : pRexxMsg;
-FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : pCHAR; host : string) : pRexxMsg;
-FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : string) : pRexxMsg;
-PROCEDURE DeleteArgstring(argstring : string);
-FUNCTION LengthArgstring(const argstring : string) : ULONG;
 
 {Here we read how to compile this unit}
 {You can remove this include and use a define instead}
@@ -514,40 +509,14 @@ var
 
 IMPLEMENTATION
 
-uses
 {$ifndef dont_use_openlib}
-amsgbox,
+uses
+  amsgbox;
 {$endif dont_use_openlib}
-pastoc;
 
 FUNCTION CreateArgstring(const argstring : string; length : ULONG) : pCHAR;
 begin
-       CreateArgstring := CreateArgstring(pas2c(argstring),length);
-end;
-
-FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : pCHAR) : pRexxMsg;
-begin
-       CreateRexxMsg := CreateRexxMsg(port,pas2c(extension),host);
-end;
-
-FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : pCHAR; host : string) : pRexxMsg;
-begin
-       CreateRexxMsg := CreateRexxMsg(port,extension,pas2c(host));
-end;
-
-FUNCTION CreateRexxMsg(const port : pMsgPort;const extension : string; host : string) : pRexxMsg;
-begin
-       CreateRexxMsg := CreateRexxMsg(port,pas2c(extension),pas2c(host));
-end;
-
-PROCEDURE DeleteArgstring(argstring : string);
-begin
-       DeleteArgstring(pas2c(argstring));
-end;
-
-FUNCTION LengthArgstring(const argstring : string) : ULONG;
-begin
-       LengthArgstring := LengthArgstring(pas2c(argstring));
+       CreateArgstring := CreateArgstring(PChar(RawByteString(argstring)),length);
 end;
 
 const

packages/amunits/src/coreunits/utility.pas

@@ -308,7 +308,7 @@ CONST
  TAG_SKIP          = 3; { skip this AND the next ti_Data items         }
 
 { differentiates user tags from control tags }
- TAG_USER          = $80000000;    { differentiates user tags from system tags}
+ TAG_USER          = LongInt($80000000);    { differentiates user tags from system tags}
 
 {* If the TAG_USER bit is set in a tag number, it tells utility.library that
  * the tag is not a control tag (like TAG_DONE, TAG_IGNORE, TAG_MORE) and is
@@ -387,47 +387,45 @@ FUNCTION Strnicmp(CONST string1 : string; CONST string2 : string; length : LONGI
 
 IMPLEMENTATION
 
-uses pastoc;
-
 
 function AllocNamedObjectA(const name : string;const TagList : pTagItem) : pNamedObject;
 begin
-       AllocNamedObjectA := AllocNamedObjectA(pas2c(name),TagList);
+       AllocNamedObjectA := AllocNamedObjectA(PChar(RawByteString(name)),TagList);
 end;
 
 FUNCTION FindNamedObject(nameSpace : pNamedObject; CONST name : string; lastObject : pNamedObject) : pNamedObject;
 begin
-       FindNamedObject := FindNamedObject(nameSpace,pas2c(name),lastObject);
+       FindNamedObject := FindNamedObject(nameSpace,PChar(RawByteString(name)),lastObject);
 end;
 
 FUNCTION Stricmp(CONST string1 : string; CONST string2 : pCHAR) : LONGINT;
 begin
-       Stricmp := Stricmp(pas2c(string1),string2);
+       Stricmp := Stricmp(PChar(RawbyteString(string1)),string2);
 end;
 
 FUNCTION Stricmp(CONST string1 : pCHAR; CONST string2 : string) : LONGINT;
 begin
-       Stricmp := Stricmp(string1,pas2c(string2));
+       Stricmp := Stricmp(string1,PChar(RawbyteString(string2)));
 end;
 
 FUNCTION Stricmp(CONST string1 : string; CONST string2 : string) : LONGINT;
 begin
-       Stricmp := Stricmp(pas2c(string1),pas2c(string2));
+       Stricmp := Stricmp(PChar(RawbyteString(string1)),PChar(RawbyteString(string2)));
 end;
 
 FUNCTION Strnicmp(CONST string1 : string; CONST string2 : pCHAR; length : LONGINT) : LONGINT;
 begin
-       Strnicmp := Strnicmp(pas2c(string1),string2,length);
+       Strnicmp := Strnicmp(PChar(RawbyteString(string1)),string2,length);
 end;
 
 FUNCTION Strnicmp(CONST string1 : pCHAR; CONST string2 : string; length : LONGINT) : LONGINT;
 begin
-       Strnicmp := Strnicmp(string1,pas2c(string2),length);
+       Strnicmp := Strnicmp(string1,PChar(RawbyteString(string2)),length);
 end;
 
 FUNCTION Strnicmp(CONST string1 : string; CONST string2 : string; length : LONGINT) : LONGINT;
 begin
-       Strnicmp := Strnicmp(pas2c(string1),pas2c(string2),length);
+       Strnicmp := Strnicmp(PChar(RawbyteString(string1)),PChar(RawbyteString(string2)),length);
 end;
 
 

packages/amunits/src/otherlibs/ahi.pas

@@ -30,10 +30,6 @@
 {$PACKRECORDS 2}
 
 {$mode objfpc}
-{$I useamigasmartlink.inc}
-{$ifdef use_amiga_smartlink}
-   {$smartlink on}
-{$endif use_amiga_smartlink}
 
 UNIT AHI;
 
@@ -503,28 +499,28 @@ VAR AHIBase : pLibrary;
      AHIDB_NOMODESCAN = 0;
 
 
+FUNCTION AHI_AddAudioMode(a0arg : pTagItem location 'a0') : longword; syscall AHIBase 150;
+FUNCTION AHI_AllocAudioA(tagList : pTagItem location 'a1') : pAHIAudioCtrl; syscall AHIBase 42;
+FUNCTION AHI_AllocAudioRequestA(tagList : pTagItem location 'a0') : pAHIAudioModeRequester; syscall AHIBase 120;
+FUNCTION AHI_AudioRequestA(Requester : pAHIAudioModeRequester location 'a0'; tagList : pTagItem location 'a1') : wordbool; syscall AHIBase 126;
+FUNCTION AHI_BestAudioIDA(tagList : pTagItem location 'a1') : longword; syscall AHIBase 114;
+FUNCTION AHI_ControlAudioA(AudioCtrl : pAHIAudioCtrl location 'a2'; tagList : pTagItem location 'a1') : longword; syscall AHIBase 60;
+PROCEDURE AHI_FreeAudio(AudioCtrl : pAHIAudioCtrl location 'a2'); syscall AHIBase 48;
+PROCEDURE AHI_FreeAudioRequest(Requester : pAHIAudioModeRequester location 'a0'); syscall AHIBase 132;
+FUNCTION AHI_GetAudioAttrsA(ID : longword location 'd0'; Audioctrl : pAHIAudioCtrl location 'a2'; tagList : pTagItem location 'a1') : wordbool; syscall AHIBase 108;
+PROCEDURE AHI_KillAudio; syscall AHIBase 54;
+FUNCTION AHI_LoadModeFile(a0arg : pCHAR location 'a0') : longword; syscall AHIBase 162;
+FUNCTION AHI_LoadSound(Sound : WORD location 'd0'; _Type : longword location 'd1'; Info : POINTER location 'a0'; AudioCtrl : pAHIAudioCtrl location 'a2') : longword; syscall AHIBase 90;
+FUNCTION AHI_NextAudioID(Last_ID : longword location 'd0') : longword; syscall AHIBase 102;
+PROCEDURE AHI_PlayA(Audioctrl : pAHIAudioCtrl location 'a2'; tagList : pTagItem location 'a1'); syscall AHIBase 138;
+FUNCTION AHI_RemoveAudioMode(d0arg : longword location 'd0') : longword; syscall AHIBase 156;
+FUNCTION AHI_SampleFrameSize(SampleType : longword location 'd0') : longword; syscall AHIBase 144;
+FUNCTION AHI_SetEffect(Effect : POINTER location 'a0'; AudioCtrl : pAHIAudioCtrl location 'a2') : longword; syscall AHIBase 084;
+PROCEDURE AHI_SetFreq(Channel : WORD location 'd0'; Freq : longword location 'd1'; AudioCtrl : pAHIAudioCtrl location 'a2'; Flags : longword location 'd2'); syscall AHIBase 72;
+PROCEDURE AHI_SetSound(Channel : WORD location 'd0'; Sound : WORD location 'd1'; Offset : longword location 'd2'; len : LONGINT location 'd3'; AudioCtrl : pAHIAudioCtrl location 'a2'; Flags : longword location 'd4'); syscall AHIBase 78;
+PROCEDURE AHI_SetVol(Channel : WORD location 'd0'; Volume : LONGINT location 'd1'; Pan : LONGINT location 'd2'; AudioCtrl : pAHIAudioCtrl location 'a2'; Flags : longword location 'd3'); syscall AHIBase 66;
+PROCEDURE AHI_UnloadSound(Sound : WORD location 'd0'; Audioctrl : pAHIAudioCtrl location 'a2'); syscall AHIBase 96;
 
-FUNCTION AHI_AddAudioMode(a0arg : pTagItem) : longword;
-FUNCTION AHI_AllocAudioA(tagList : pTagItem) : pAHIAudioCtrl;
-FUNCTION AHI_AllocAudioRequestA(tagList : pTagItem) : pAHIAudioModeRequester;
-FUNCTION AHI_AudioRequestA(Requester : pAHIAudioModeRequester; tagList : pTagItem) : BOOLEAN;
-FUNCTION AHI_BestAudioIDA(tagList : pTagItem) : longword;
-FUNCTION AHI_ControlAudioA(AudioCtrl : pAHIAudioCtrl; tagList : pTagItem) : longword;
-PROCEDURE AHI_FreeAudio(AudioCtrl : pAHIAudioCtrl);
-PROCEDURE AHI_FreeAudioRequest(Requester : pAHIAudioModeRequester);
-FUNCTION AHI_GetAudioAttrsA(ID : longword; Audioctrl : pAHIAudioCtrl; tagList : pTagItem) : BOOLEAN;
-PROCEDURE AHI_KillAudio;
-FUNCTION AHI_LoadModeFile(a0arg : pCHAR) : longword;
-FUNCTION AHI_LoadSound(Sound : WORD; _Type : longword; Info : POINTER; AudioCtrl : pAHIAudioCtrl) : longword;
-FUNCTION AHI_NextAudioID(Last_ID : longword) : longword;
-PROCEDURE AHI_PlayA(Audioctrl : pAHIAudioCtrl; tagList : pTagItem);
-FUNCTION AHI_RemoveAudioMode(d0arg : longword) : longword;
-FUNCTION AHI_SampleFrameSize(SampleType : longword) : longword;
-FUNCTION AHI_SetEffect(Effect : POINTER; AudioCtrl : pAHIAudioCtrl) : longword;
-PROCEDURE AHI_SetFreq(Channel : WORD; Freq : longword; AudioCtrl : pAHIAudioCtrl; Flags : longword);
-PROCEDURE AHI_SetSound(Channel : WORD; Sound : WORD; Offset : longword; len : LONGINT; AudioCtrl : pAHIAudioCtrl; Flags : longword);
-PROCEDURE AHI_SetVol(Channel : WORD; Volume : LONGINT; Pan : LONGINT; AudioCtrl : pAHIAudioCtrl; Flags : longword);
-PROCEDURE AHI_UnloadSound(Sound : WORD; Audioctrl : pAHIAudioCtrl);
 {
  Functions and procedures with array of const go here
 }
@@ -553,277 +549,6 @@ amsgbox,
 {$endif dont_use_openlib}
 tagsarray;
 
-FUNCTION AHI_AddAudioMode(a0arg : pTagItem) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a0arg,A0
-        MOVEA.L AHIBase,A6
-        JSR     -150(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_AllocAudioA(tagList : pTagItem) : pAHIAudioCtrl;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L tagList,A1
-        MOVEA.L AHIBase,A6
-        JSR     -042(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_AllocAudioRequestA(tagList : pTagItem) : pAHIAudioModeRequester;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L tagList,A0
-        MOVEA.L AHIBase,A6
-        JSR     -120(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_AudioRequestA(Requester : pAHIAudioModeRequester; tagList : pTagItem) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Requester,A0
-        MOVEA.L tagList,A1
-        MOVEA.L AHIBase,A6
-        JSR     -126(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_BestAudioIDA(tagList : pTagItem) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L tagList,A1
-        MOVEA.L AHIBase,A6
-        JSR     -114(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_ControlAudioA(AudioCtrl : pAHIAudioCtrl; tagList : pTagItem) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L AudioCtrl,A2
-        MOVEA.L tagList,A1
-        MOVEA.L AHIBase,A6
-        JSR     -060(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE AHI_FreeAudio(AudioCtrl : pAHIAudioCtrl);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L AudioCtrl,A2
-        MOVEA.L AHIBase,A6
-        JSR     -048(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE AHI_FreeAudioRequest(Requester : pAHIAudioModeRequester);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Requester,A0
-        MOVEA.L AHIBase,A6
-        JSR     -132(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION AHI_GetAudioAttrsA(ID : longword; Audioctrl : pAHIAudioCtrl; tagList : pTagItem) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  ID,D0
-        MOVEA.L Audioctrl,A2
-        MOVEA.L tagList,A1
-        MOVEA.L AHIBase,A6
-        JSR     -108(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-PROCEDURE AHI_KillAudio;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L AHIBase,A6
-        JSR     -054(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION AHI_LoadModeFile(a0arg : pCHAR) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a0arg,A0
-        MOVEA.L AHIBase,A6
-        JSR     -162(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_LoadSound(Sound : WORD; _Type : longword; Info : POINTER; AudioCtrl : pAHIAudioCtrl) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Sound,D0
-        MOVE.L  _Type,D1
-        MOVEA.L Info,A0
-        MOVEA.L AudioCtrl,A2
-        MOVEA.L AHIBase,A6
-        JSR     -090(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_NextAudioID(Last_ID : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Last_ID,D0
-        MOVEA.L AHIBase,A6
-        JSR     -102(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE AHI_PlayA(Audioctrl : pAHIAudioCtrl; tagList : pTagItem);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Audioctrl,A2
-        MOVEA.L tagList,A1
-        MOVEA.L AHIBase,A6
-        JSR     -138(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION AHI_RemoveAudioMode(d0arg : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  d0arg,D0
-        MOVEA.L AHIBase,A6
-        JSR     -156(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_SampleFrameSize(SampleType : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  SampleType,D0
-        MOVEA.L AHIBase,A6
-        JSR     -144(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION AHI_SetEffect(Effect : POINTER; AudioCtrl : pAHIAudioCtrl) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Effect,A0
-        MOVEA.L AudioCtrl,A2
-        MOVEA.L AHIBase,A6
-        JSR     -084(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE AHI_SetFreq(Channel : WORD; Freq : longword; AudioCtrl : pAHIAudioCtrl; Flags : longword);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Channel,D0
-        MOVE.L  Freq,D1
-        MOVEA.L AudioCtrl,A2
-        MOVE.L  Flags,D2
-        MOVEA.L AHIBase,A6
-        JSR     -072(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE AHI_SetSound(Channel : WORD; Sound : WORD; Offset : longword; len : LONGINT; AudioCtrl : pAHIAudioCtrl; Flags : longword);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Channel,D0
-        MOVE.L  Sound,D1
-        MOVE.L  Offset,D2
-        MOVE.L  len,D3
-        MOVEA.L AudioCtrl,A2
-        MOVE.L  Flags,D4
-        MOVEA.L AHIBase,A6
-        JSR     -078(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE AHI_SetVol(Channel : WORD; Volume : LONGINT; Pan : LONGINT; AudioCtrl : pAHIAudioCtrl; Flags : longword);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Channel,D0
-        MOVE.L  Volume,D1
-        MOVE.L  Pan,D2
-        MOVEA.L AudioCtrl,A2
-        MOVE.L  Flags,D3
-        MOVEA.L AHIBase,A6
-        JSR     -066(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE AHI_UnloadSound(Sound : WORD; Audioctrl : pAHIAudioCtrl);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Sound,D0
-        MOVEA.L Audioctrl,A2
-        MOVEA.L AHIBase,A6
-        JSR     -096(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
 {
  Functions and procedures with array of const go here
 }

packages/amunits/src/otherlibs/cybergraphics.pas

@@ -29,10 +29,6 @@
 }
 
 {$mode objfpc}
-{$I useamigasmartlink.inc}
-{$ifdef use_amiga_smartlink}
-   {$smartlink on}
-{$endif use_amiga_smartlink}
 
 UNIT CYBERGRAPHICS;
 
@@ -224,28 +220,28 @@ const
      BMB_SPECIALFMT = 7;
      BMF_SPECIALFMT = 1 shl BMB_SPECIALFMT;
 
-FUNCTION AllocCModeListTagList(ModeListTags : pTagItem) : pList;
-FUNCTION BestCModeIDTagList(BestModeIDTags : pTagItem) : longword;
-FUNCTION CModeRequestTagList(ModeRequest : POINTER; ModeRequestTags : pTagItem) : longword;
-PROCEDURE CVideoCtrlTagList(ViewPort : pViewPort; TagList : pTagItem);
-PROCEDURE DoCDrawMethodTagList(Hook : pHook; a1arg : pRastPort; TagList : pTagItem);
-FUNCTION ExtractColor(a0arg : pRastPort; BitMap : pBitMap; Colour : longword; SrcX : longword; SrcY : longword; Width : longword; Height : longword) : longword;
-FUNCTION FillPixelArray(a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD; ARGB : longword) : longword;
-PROCEDURE FreeCModeList(ModeList : pList);
-FUNCTION GetCyberIDAttr(CyberIDAttr : longword; CyberDisplayModeID : longword) : longword;
-FUNCTION GetCyberMapAttr(CyberGfxBitmap : pBitMap; CyberAttrTag : longword) : longword;
-FUNCTION InvertPixelArray(a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD) : longword;
-FUNCTION IsCyberModeID(displayID : longword) : BOOLEAN;
-FUNCTION LockBitMapTagList(BitMap : POINTER; TagList : pTagItem) : POINTER;
-FUNCTION MovePixelArray(SrcX : WORD; SrcY : WORD; a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD) : longword;
-FUNCTION ReadPixelArray(destRect : POINTER; destX : WORD; destY : WORD; destMod : WORD; a1arg : pRastPort; SrcX : WORD; SrcY : WORD; SizeX : WORD; SizeY : WORD; DestFormat : byte) : longword;
-FUNCTION ReadRGBPixel(a1arg : pRastPort; x : WORD; y : WORD) : longword;
-FUNCTION ScalePixelArray(srcRect : POINTER; SrcW : WORD; SrcH : WORD; SrcMod : WORD; a1arg : pRastPort; DestX : WORD; DestY : WORD; DestW : WORD; DestH : WORD; SrcFormat : byte) : LONGINT;
-PROCEDURE UnLockBitMap(Handle : POINTER);
-PROCEDURE UnLockBitMapTagList(Handle : POINTER; TagList : pTagItem);
-FUNCTION WriteLUTPixelArray(srcRect : POINTER; SrcX : WORD; SrcY : WORD; SrcMod : WORD; a1arg : pRastPort; ColorTab : POINTER; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD; CTFormat : byte) : longword;
-FUNCTION WritePixelArray(srcRect : POINTER; SrcX : WORD; SrcY : WORD; SrcMod : WORD; a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD; SrcFormat : byte) : longword;
-FUNCTION WriteRGBPixel(a1arg : pRastPort; x : WORD; y : WORD; argb : longword) : LONGINT;
+FUNCTION AllocCModeListTagList(ModeListTags : pTagItem location 'a1') : pList; syscall CyberGfxBase 072;
+FUNCTION BestCModeIDTagList(BestModeIDTags : pTagItem location 'a0') : longword; syscall CyberGfxBase 060;
+FUNCTION CModeRequestTagList(ModeRequest : POINTER location 'a0'; ModeRequestTags : pTagItem location 'a1') : longword; syscall CyberGfxBase 066;
+PROCEDURE CVideoCtrlTagList(ViewPort : pViewPort location 'a0'; TagList : pTagItem location 'a1'); syscall CyberGfxBase 162;
+PROCEDURE DoCDrawMethodTagList(Hook : pHook location 'a0'; a1arg : pRastPort location 'a1'; TagList : pTagItem location 'a2'); syscall CyberGfxBase 156;
+FUNCTION ExtractColor(a0arg : pRastPort location 'a0'; BitMap : pBitMap location 'a1'; Colour : longword location 'd0'; SrcX : longword location 'd1'; SrcY : longword location 'd2'; Width : longword location 'd3'; Height : longword location 'd4') : longword; syscall CyberGfxBase 186;
+FUNCTION FillPixelArray(a1arg : pRastPort location 'a1'; DestX : WORD location 'd0'; DestY : WORD location 'd1'; SizeX : WORD location 'd2'; SizeY : WORD location 'd3'; ARGB : longword location 'd4') : longword; syscall CyberGfxBase 150;
+PROCEDURE FreeCModeList(ModeList : pList location 'a0'); syscall CyberGfxBase 078;
+FUNCTION GetCyberIDAttr(CyberIDAttr : longword location 'd0'; CyberDisplayModeID : longword location 'd1') : longword; syscall CyberGfxBase 102;
+FUNCTION GetCyberMapAttr(CyberGfxBitmap : pBitMap location 'a0'; CyberAttrTag : longword location 'd0') : longword; syscall CyberGfxBase 096;
+FUNCTION InvertPixelArray(a1arg : pRastPort location 'a1'; DestX : WORD location 'd0'; DestY : WORD location 'd1'; SizeX : WORD location 'd2'; SizeY : WORD location 'd3') : longword; syscall CyberGfxBase 144;
+FUNCTION IsCyberModeID(displayID : longword location 'd0') : wordbool; syscall CyberGfxBase 054;
+FUNCTION LockBitMapTagList(BitMap : POINTER location 'a0'; TagList : pTagItem location 'a1') : POINTER; syscall CyberGfxBase 168;
+FUNCTION MovePixelArray(SrcX : WORD location 'd0'; SrcY : WORD location 'd1'; a1arg : pRastPort location 'a1'; DestX : WORD location 'd2'; DestY : WORD location 'd3'; SizeX : WORD location 'd4'; SizeY : WORD location 'd5') : longword; syscall CyberGfxBase 132;
+FUNCTION ReadPixelArray(destRect : POINTER location 'a0'; destX : WORD location 'd0'; destY : WORD location 'd1'; destMod : WORD location 'd2'; a1arg : pRastPort location 'a1'; SrcX : WORD location 'd3'; SrcY : WORD location 'd4'; SizeX : WORD location 'd5'; SizeY : WORD location 'd6'; DestFormat : byte location 'd7') : longword; syscall CyberGfxBase 120;
+FUNCTION ReadRGBPixel(a1arg : pRastPort location 'a1'; x : WORD location 'd0'; y : WORD location 'd1') : longword; syscall CyberGfxBase 108;
+FUNCTION ScalePixelArray(srcRect : POINTER location 'a0'; SrcW : WORD location 'd0'; SrcH : WORD location 'd1'; SrcMod : WORD location 'd2'; a1arg : pRastPort location 'a1'; DestX : WORD location 'd3'; DestY : WORD location 'd4'; DestW : WORD location 'd5'; DestH : WORD location 'd6'; SrcFormat : byte location 'd7') : LONGINT; syscall CyberGfxBase 090;
+PROCEDURE UnLockBitMap(Handle : POINTER location 'a0'); syscall CyberGfxBase 174;
+PROCEDURE UnLockBitMapTagList(Handle : POINTER location 'a0'; TagList : pTagItem location 'a1'); syscall CyberGfxBase 180;
+FUNCTION WriteLUTPixelArray(srcRect : POINTER location 'a0'; SrcX : WORD location 'd0'; SrcY : WORD location 'd1'; SrcMod : WORD location 'd2'; a1arg : pRastPort location 'a1'; ColorTab : POINTER location 'a2'; DestX : WORD location 'd3'; DestY : WORD location 'd4'; SizeX : WORD location 'd5'; SizeY : WORD location 'd6'; CTFormat : byte location 'd7') : longword; syscall CyberGfxBase 198;
+FUNCTION WritePixelArray(srcRect : POINTER location 'a0'; SrcX : WORD location 'd0'; SrcY : WORD location 'd1'; SrcMod : WORD location 'd2'; a1arg : pRastPort location 'a1'; DestX : WORD location 'd3'; DestY : WORD location 'd4'; SizeX : WORD location 'd5'; SizeY : WORD location 'd6'; SrcFormat : byte location 'd7') : longword; syscall CyberGfxBase 126;
+FUNCTION WriteRGBPixel(a1arg : pRastPort location 'a1'; x : WORD location 'd0'; y : WORD location 'd1'; argb : longword location 'd2') : LONGINT; syscall CyberGfxBase 114;
 {
  Functions and procedures with array of const go here
 }
@@ -277,339 +273,6 @@ amsgbox,
 {$endif dont_use_openlib}
 tagsarray;
 
-FUNCTION AllocCModeListTagList(ModeListTags : pTagItem) : pList;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ModeListTags,A1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -072(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION BestCModeIDTagList(BestModeIDTags : pTagItem) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L BestModeIDTags,A0
-        MOVEA.L CyberGfxBase,A6
-        JSR     -060(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION CModeRequestTagList(ModeRequest : POINTER; ModeRequestTags : pTagItem) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ModeRequest,A0
-        MOVEA.L ModeRequestTags,A1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -066(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE CVideoCtrlTagList(ViewPort : pViewPort; TagList : pTagItem);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ViewPort,A0
-        MOVEA.L TagList,A1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -162(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE DoCDrawMethodTagList(Hook : pHook; a1arg : pRastPort; TagList : pTagItem);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Hook,A0
-        MOVEA.L a1arg,A1
-        MOVEA.L TagList,A2
-        MOVEA.L CyberGfxBase,A6
-        JSR     -156(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION ExtractColor(a0arg : pRastPort; BitMap : pBitMap; Colour : longword; SrcX : longword; SrcY : longword; Width : longword; Height : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a0arg,A0
-        MOVEA.L BitMap,A1
-        MOVE.L  Colour,D0
-        MOVE.L  SrcX,D1
-        MOVE.L  SrcY,D2
-        MOVE.L  Width,D3
-        MOVE.L  Height,D4
-        MOVEA.L CyberGfxBase,A6
-        JSR     -186(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION FillPixelArray(a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD; ARGB : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a1arg,A1
-        MOVE.L  DestX,D0
-        MOVE.L  DestY,D1
-        MOVE.L  SizeX,D2
-        MOVE.L  SizeY,D3
-        MOVE.L  ARGB,D4
-        MOVEA.L CyberGfxBase,A6
-        JSR     -150(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE FreeCModeList(ModeList : pList);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ModeList,A0
-        MOVEA.L CyberGfxBase,A6
-        JSR     -078(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION GetCyberIDAttr(CyberIDAttr : longword; CyberDisplayModeID : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  CyberIDAttr,D0
-        MOVE.L  CyberDisplayModeID,D1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -102(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION GetCyberMapAttr(CyberGfxBitmap : pBitMap; CyberAttrTag : longword) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L CyberGfxBitmap,A0
-        MOVE.L  CyberAttrTag,D0
-        MOVEA.L CyberGfxBase,A6
-        JSR     -096(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION InvertPixelArray(a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a1arg,A1
-        MOVE.L  DestX,D0
-        MOVE.L  DestY,D1
-        MOVE.L  SizeX,D2
-        MOVE.L  SizeY,D3
-        MOVEA.L CyberGfxBase,A6
-        JSR     -144(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION IsCyberModeID(displayID : longword) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  displayID,D0
-        MOVEA.L CyberGfxBase,A6
-        JSR     -054(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION LockBitMapTagList(BitMap : POINTER; TagList : pTagItem) : POINTER;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L BitMap,A0
-        MOVEA.L TagList,A1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -168(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MovePixelArray(SrcX : WORD; SrcY : WORD; a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  SrcX,D0
-        MOVE.L  SrcY,D1
-        MOVEA.L a1arg,A1
-        MOVE.L  DestX,D2
-        MOVE.L  DestY,D3
-        MOVE.L  SizeX,D4
-        MOVE.L  SizeY,D5
-        MOVEA.L CyberGfxBase,A6
-        JSR     -132(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION ReadPixelArray(destRect : POINTER; destX : WORD; destY : WORD; destMod : WORD; a1arg : pRastPort; SrcX : WORD; SrcY : WORD; SizeX : WORD; SizeY : WORD; DestFormat : byte) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L destRect,A0
-        MOVE.L  destX,D0
-        MOVE.L  destY,D1
-        MOVE.L  destMod,D2
-        MOVEA.L a1arg,A1
-        MOVE.L  SrcX,D3
-        MOVE.L  SrcY,D4
-        MOVE.L  SizeX,D5
-        MOVE.L  SizeY,D6
-        MOVE.L  DestFormat,D7
-        MOVEA.L CyberGfxBase,A6
-        JSR     -120(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION ReadRGBPixel(a1arg : pRastPort; x : WORD; y : WORD) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a1arg,A1
-        MOVE.L  x,D0
-        MOVE.L  y,D1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -108(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION ScalePixelArray(srcRect : POINTER; SrcW : WORD; SrcH : WORD; SrcMod : WORD; a1arg : pRastPort; DestX : WORD; DestY : WORD; DestW : WORD; DestH : WORD; SrcFormat : byte) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L srcRect,A0
-        MOVE.L  SrcW,D0
-        MOVE.L  SrcH,D1
-        MOVE.L  SrcMod,D2
-        MOVEA.L a1arg,A1
-        MOVE.L  DestX,D3
-        MOVE.L  DestY,D4
-        MOVE.L  DestW,D5
-        MOVE.L  DestH,D6
-        MOVE.L  SrcFormat,D7
-        MOVEA.L CyberGfxBase,A6
-        JSR     -090(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE UnLockBitMap(Handle : POINTER);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Handle,A0
-        MOVEA.L CyberGfxBase,A6
-        JSR     -174(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE UnLockBitMapTagList(Handle : POINTER; TagList : pTagItem);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Handle,A0
-        MOVEA.L TagList,A1
-        MOVEA.L CyberGfxBase,A6
-        JSR     -180(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION WriteLUTPixelArray(srcRect : POINTER; SrcX : WORD; SrcY : WORD; SrcMod : WORD; a1arg : pRastPort; ColorTab : POINTER; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD; CTFormat : byte) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L srcRect,A0
-        MOVE.L  SrcX,D0
-        MOVE.L  SrcY,D1
-        MOVE.L  SrcMod,D2
-        MOVEA.L a1arg,A1
-        MOVEA.L ColorTab,A2
-        MOVE.L  DestX,D3
-        MOVE.L  DestY,D4
-        MOVE.L  SizeX,D5
-        MOVE.L  SizeY,D6
-        MOVE.L  CTFormat,D7
-        MOVEA.L CyberGfxBase,A6
-        JSR     -198(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION WritePixelArray(srcRect : POINTER; SrcX : WORD; SrcY : WORD; SrcMod : WORD; a1arg : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD; SrcFormat : byte) : longword;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L srcRect,A0
-        MOVE.L  SrcX,D0
-        MOVE.L  SrcY,D1
-        MOVE.L  SrcMod,D2
-        MOVEA.L a1arg,A1
-        MOVE.L  DestX,D3
-        MOVE.L  DestY,D4
-        MOVE.L  SizeX,D5
-        MOVE.L  SizeY,D6
-        MOVE.L  SrcFormat,D7
-        MOVEA.L CyberGfxBase,A6
-        JSR     -126(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION WriteRGBPixel(a1arg : pRastPort; x : WORD; y : WORD; argb : longword) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L a1arg,A1
-        MOVE.L  x,D0
-        MOVE.L  y,D1
-        MOVE.L  argb,D2
-        MOVEA.L CyberGfxBase,A6
-        JSR     -114(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
 {
  Functions and procedures with array of const go here
 }

packages/amunits/src/otherlibs/mui.pas

@@ -1520,12 +1520,12 @@ uses exec, intuition,utility,agraphics,iffparse;
      { MUI_MinMax structure holds information about minimum, maximum
        and default dimensions of an object.  }
        tMUI_MinMax = record
-            MinWidth : WORD;
-            MinHeight : WORD;
-            MaxWidth : WORD;
-            MaxHeight : WORD;
-            DefWidth : WORD;
-            DefHeight : WORD;
+            MinWidth : SmallInt;
+            MinHeight : SmallInt;
+            MaxWidth : SmallInt;
+            MaxHeight : SmallInt;
+            DefWidth : SmallInt;
+            DefHeight : SmallInt;
          end;
        pMUI_MinMax = ^tMUI_MinMax;
 
@@ -3478,32 +3478,33 @@ uses exec, intuition,utility,agraphics,iffparse;
          end;
        pMUI_CustomClass = ^tMUI_CustomClass;
 
-FUNCTION MUI_NewObjectA(class_ : pChar; tags : pTagItem) : pObject_;
-PROCEDURE MUI_DisposeObject(obj : pObject_);
-FUNCTION MUI_RequestA(app : POINTER; win : POINTER; flags : LONGBITS; title : pChar; gadgets : pChar; format : pChar; params : POINTER) : LONGINT;
-FUNCTION MUI_AllocAslRequest(typ : ULONG; tags : pTagItem) : POINTER;
-FUNCTION MUI_AslRequest(req : POINTER; tags : pTagItem) : BOOLEAN;
-PROCEDURE MUI_FreeAslRequest(req : POINTER);
-FUNCTION MUI_Error : LONGINT;
-FUNCTION MUI_SetError(errnum : LONGINT) : LONGINT;
-FUNCTION MUI_GetClass(name : pCHar) : pIClass;
-PROCEDURE MUI_FreeClass(cl : pIClass);
-PROCEDURE MUI_RequestIDCMP(obj : pObject_; flags : ULONG);
-PROCEDURE MUI_RejectIDCMP(obj : pObject_; flags : ULONG);
-PROCEDURE MUI_Redraw(obj : pObject_; flags : ULONG);
-FUNCTION MUI_CreateCustomClass(base : pLibrary; supername : pChar; supermcc : pMUI_CustomClass; datasize : LONGINT; dispatcher : POINTER) : pMUI_CustomClass;
-FUNCTION MUI_DeleteCustomClass(mcc : pMUI_CustomClass) : BOOLEAN;
-FUNCTION MUI_MakeObjectA(typ: LONGINT; params : pULONG) : pObject_;
-FUNCTION MUI_Layout(obj : pObject_; l : LONGINT; t : LONGINT; w : LONGINT; h : LONGINT; flags : ULONG) : BOOLEAN;
-FUNCTION MUI_ObtainPen(mri : pMUI_RenderInfo; spec : pMUI_PenSpec; flags : ULONG) : LONGINT;
-PROCEDURE MUI_ReleasePen(mri : pMUI_RenderInfo; pen : LONGINT);
-FUNCTION MUI_AddClipping(mri : pMUI_RenderInfo; l : smallint; t : smallint; w : smallint; h : smallint) : POINTER;
-PROCEDURE MUI_RemoveClipping(mri : pMUI_RenderInfo; h : POINTER);
-FUNCTION MUI_AddClipRegion(mri : pMUI_RenderInfo; region : pRegion) : POINTER;
-PROCEDURE MUI_RemoveClipRegion(mri : pMUI_RenderInfo; region : POINTER);
-FUNCTION MUI_BeginRefresh(mri : pMUI_RenderInfo; flags : ULONG) : BOOLEAN;
-PROCEDURE MUI_EndRefresh(mri : pMUI_RenderInfo; flags : ULONG);
+VAR MUIMasterBase : pLibrary;
 
+FUNCTION MUI_NewObjectA(class_ : pCHar location 'a0'; tags : pTagItem location 'a1') : pObject_; syscall MUIMasterBase 030;
+PROCEDURE MUI_DisposeObject(obj : pObject_ location 'a0'); syscall MUIMasterBase 036;
+FUNCTION MUI_RequestA(app : POINTER location 'd0'; win : POINTER location 'd1'; flags : LONGBITS location 'd2'; title : pCHar location 'a0'; gadgets : pChar location 'a1'; format : pChar location 'a2'; params : POINTER location 'a3') : LONGINT; syscall MUIMasterBase 042;
+FUNCTION MUI_AllocAslRequest(typ : ULONG location 'd0'; tags : pTagItem location 'a0') : POINTER; syscall MUIMasterBase 048;
+FUNCTION MUI_AslRequest(req : POINTER location 'a0'; tags : pTagItem location 'a1') : WordBool; syscall MUIMasterBase 054;
+PROCEDURE MUI_FreeAslRequest(req : POINTER location 'a0'); syscall MUIMasterBase 060;
+FUNCTION MUI_Error : LONGINT; syscall MUIMasterBase 066;
+FUNCTION MUI_SetError(errnum : LONGINT location 'd0') : LONGINT; syscall MUIMasterBase 072;
+FUNCTION MUI_GetClass(name : pChar location 'a0') : pIClass; syscall MUIMasterBase 078;
+PROCEDURE MUI_FreeClass(cl : pIClass location 'a0'); syscall MUIMasterBase 084;
+PROCEDURE MUI_RequestIDCMP(obj : pObject_ location 'a0'; flags : ULONG location 'd0'); syscall MUIMasterBase 090;
+PROCEDURE MUI_RejectIDCMP(obj : pObject_ location 'a0'; flags : ULONG location 'd0'); syscall MUIMasterBase 096;
+PROCEDURE MUI_Redraw(obj : pObject_ location 'a0'; flags : ULONG location 'd0'); syscall MUIMasterBase 102;
+FUNCTION MUI_CreateCustomClass(base : pLibrary location 'a0'; supername : pChar location 'a1'; supermcc : pMUI_CustomClass location 'a2'; datasize : LONGINT location 'd0'; dispatcher : POINTER location 'a3') : pMUI_CustomClass; syscall MUIMasterBase 108;
+FUNCTION MUI_DeleteCustomClass(mcc : pMUI_CustomClass location 'a0') : WordBool; syscall MUIMasterBase 114;
+FUNCTION MUI_MakeObjectA(typ : LONGINT location 'd0'; params : pULONG location 'a0') : pObject_; syscall MUIMasterBase 120;
+FUNCTION MUI_Layout(obj : pObject_ location 'a0'; l : LONGINT location 'd0'; t : LONGINT location 'd1'; w : LONGINT location 'd2'; h : LONGINT location 'd3'; flags : ULONG location 'd4') : WordBool; syscall MUIMasterBase 126;
+FUNCTION MUI_ObtainPen(mri : pMUI_RenderInfo location 'a0'; spec : pMUI_PenSpec location 'a1'; flags : ULONG location 'd0') : LONGINT; syscall MUIMasterBase 156;
+PROCEDURE MUI_ReleasePen(mri : pMUI_RenderInfo location 'a0'; pen : LONGINT location 'd0'); syscall MUIMasterBase 162;
+FUNCTION MUI_AddClipping(mri : pMUI_RenderInfo location 'a0'; l : smallint location 'd0'; t : smallint location 'd1'; w : smallint location 'd2'; h : smallint location 'd3') : POINTER; syscall MUIMasterBase 168;
+PROCEDURE MUI_RemoveClipping(mri : pMUI_RenderInfo location 'a0'; h : POINTER location 'a1'); syscall MUIMasterBase 174;
+FUNCTION MUI_AddClipRegion(mri : pMUI_RenderInfo location 'a0'; region : pRegion location 'a1') : POINTER; syscall MUIMasterBase 180;
+PROCEDURE MUI_RemoveClipRegion(mri : pMUI_RenderInfo location 'a0'; region : POINTER location 'a1'); syscall MUIMAsterBase 186;
+FUNCTION MUI_BeginRefresh(mri : pMUI_RenderInfo location 'a0'; flags : ULONG location 'd0') : WordBool; syscall MUIMasterBase 192;
+PROCEDURE MUI_EndRefresh(mri : pMUI_RenderInfo location 'a0'; flags : ULONG location 'd0'); syscall MUIMasterBase 198;
 
 (*
 ** some procedures to get some information about our object
@@ -3582,8 +3583,6 @@ FUNCTION MUI_MakeObject(_type : LONGINT; const params : Array Of Const) : pULONG
 FUNCTION MUI_NewObject(a0arg : pCHAR; const tags : Array Of Const) : pULONG;
 FUNCTION MUI_Request(app : POINTER; win : POINTER; flags : longword; title : pCHAR; gadgets : pCHAR; format : pCHAR; const params : Array Of Const) : LONGINT;
 
-VAR MUIMasterBase : pLibrary;
-
 {You can remove this include and use a define instead}
 {$I useautoopenlib.inc}
 {$ifdef use_init_openlib}
@@ -3873,342 +3872,6 @@ begin
     MUIV_Window_Width_Screen := (-200 - (p));
 end;
 
-FUNCTION MUI_NewObjectA(class_ : pCHar; tags : pTagItem) : pObject_;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L class_,A0
-        MOVEA.L tags,A1
-        MOVEA.L MUIMasterBase,A6
-        JSR     -030(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_DisposeObject(obj : pObject_);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L obj,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -036(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MUI_RequestA(app : POINTER; win : POINTER; flags : LONGBITS; title : pCHar; gadgets : pChar; format : pChar; params : POINTER) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  app,D0
-        MOVE.L  win,D1
-        MOVE.L  flags,D2
-        MOVEA.L title,A0
-        MOVEA.L gadgets,A1
-        MOVEA.L format,A2
-        MOVEA.L params,A3
-        MOVEA.L MUIMasterBase,A6
-        JSR     -042(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_AllocAslRequest(typ : ULONG; tags : pTagItem) : POINTER;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  typ,D0
-        MOVEA.L tags,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -048(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_AslRequest(req : POINTER; tags : pTagItem) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L req,A0
-        MOVEA.L tags,A1
-        MOVEA.L MUIMasterBase,A6
-        JSR     -054(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_FreeAslRequest(req : POINTER);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L req,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -060(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MUI_Error : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L MUIMasterBase,A6
-        JSR     -066(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_SetError(errnum : LONGINT) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  errnum,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -072(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_GetClass(name : pChar) : pIClass;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L name,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -078(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_FreeClass(cl : pIClass);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L cl,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -084(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE MUI_RequestIDCMP(obj : pObject_; flags : ULONG);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L obj,A0
-        MOVE.L  flags,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -090(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE MUI_RejectIDCMP(obj : pObject_; flags : ULONG);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L obj,A0
-        MOVE.L  flags,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -096(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE MUI_Redraw(obj : pObject_; flags : ULONG);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L obj,A0
-        MOVE.L  flags,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -102(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MUI_CreateCustomClass(base : pLibrary; supername : pChar; supermcc : pMUI_CustomClass; datasize : LONGINT; dispatcher : POINTER) : pMUI_CustomClass;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L base,A0
-        MOVEA.L supername,A1
-        MOVEA.L supermcc,A2
-        MOVE.L  datasize,D0
-        MOVEA.L dispatcher,A3
-        MOVEA.L MUIMasterBase,A6
-        JSR     -108(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_DeleteCustomClass(mcc : pMUI_CustomClass) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mcc,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -114(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_MakeObjectA(typ : LONGINT; params : pULONG) : pObject_;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  typ,D0
-        MOVEA.L params,A0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -120(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_Layout(obj : pObject_; l : LONGINT; t : LONGINT; w : LONGINT; h : LONGINT; flags : ULONG) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L obj,A0
-        MOVE.L  l,D0
-        MOVE.L  t,D1
-        MOVE.L  w,D2
-        MOVE.L  h,D3
-        MOVE.L  flags,D4
-        MOVEA.L MUIMasterBase,A6
-        JSR     -126(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION MUI_ObtainPen(mri : pMUI_RenderInfo; spec : pMUI_PenSpec; flags : ULONG) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVEA.L spec,A1
-        MOVE.L  flags,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -156(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_ReleasePen(mri : pMUI_RenderInfo; pen : LONGINT);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVE.L  pen,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -162(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MUI_AddClipping(mri : pMUI_RenderInfo; l : smallint; t : smallint; w : smallint; h : smallint) : POINTER;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVE.L  l,D0
-        MOVE.L  t,D1
-        MOVE.L  w,D2
-        MOVE.L  h,D3
-        MOVEA.L MUIMasterBase,A6
-        JSR     -168(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_RemoveClipping(mri : pMUI_RenderInfo; h : POINTER);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVEA.L h,A1
-        MOVEA.L MUIMasterBase,A6
-        JSR     -174(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MUI_AddClipRegion(mri : pMUI_RenderInfo; region : pRegion) : POINTER;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVEA.L region,A1
-        MOVEA.L MUIMasterBase,A6
-        JSR     -180(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_RemoveClipRegion(mri : pMUI_RenderInfo; region : POINTER);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVEA.L region,A1
-        MOVEA.L MUIMasterBase,A6
-        JSR     -186(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION MUI_BeginRefresh(mri : pMUI_RenderInfo; flags : ULONG) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVE.L  flags,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -192(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-PROCEDURE MUI_EndRefresh(mri : pMUI_RenderInfo; flags : ULONG);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L mri,A0
-        MOVE.L  flags,D0
-        MOVEA.L MUIMasterBase,A6
-        JSR     -198(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-
 {
  Functions and procedures with array of const go here
 }

packages/amunits/src/otherlibs/picasso96api.pas

@@ -35,10 +35,6 @@
 
 }
 {$mode objfpc}
-{$I useamigasmartlink.inc}
-{$ifdef use_amiga_smartlink}
-    {$smartlink on}
-{$endif use_amiga_smartlink}
 
 UNIT PICASSO96API;
 
@@ -407,33 +403,32 @@ USES Exec, utility, agraphics, intuition;
 
 VAR P96Base : pLibrary;
 
-FUNCTION p96AllocBitMap(SizeX : Ulong; SizeY : Ulong; Depth : Ulong; Flags : Ulong; Friend : pBitMap; RGBFormat : RGBFTYPE) : pBitMap;
-PROCEDURE p96FreeBitMap(BitMap : pBitMap);
-FUNCTION p96GetBitMapAttr(BitMap : pBitMap; Attribute : Ulong) : Ulong;
-FUNCTION p96LockBitMap(BitMap : pBitMap; Buffer : pCHAR; Size : Ulong) : LONGINT;
-PROCEDURE p96UnlockBitMap(BitMap : pBitMap; Lock : LONGINT);
-FUNCTION p96BestModeIDTagList(Tags : pTagItem) : Ulong;
-FUNCTION p96RequestModeIDTagList(Tags : pTagItem) : Ulong;
-FUNCTION p96AllocModeListTagList(Tags : pTagItem) : pList;
-PROCEDURE p96FreeModeList(List : pList);
-FUNCTION p96GetModeIDAttr(Mode : Ulong; Attribute : Ulong) : Ulong;
-FUNCTION p96OpenScreenTagList(Tags : pTagItem) : pScreen;
-FUNCTION p96CloseScreen(Screen : pScreen) : BOOLEAN;
-PROCEDURE p96WritePixelArray(ri : pRenderInfo; SrcX : WORD; SrcY : WORD; rp : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD);
-PROCEDURE p96ReadPixelArray(ri : pRenderInfo; DestX : WORD; DestY : WORD; rp : pRastPort; SrcX : WORD; SrcY : WORD; SizeX : WORD; SizeY : WORD);
-FUNCTION p96WritePixel(rp : pRastPort; x : WORD; y : WORD; color : Ulong) : Ulong;
-FUNCTION p96ReadPixel(rp : pRastPort; x : WORD; y : WORD) : Ulong;
-PROCEDURE p96RectFill(rp : pRastPort; MinX : WORD; MinY : WORD; MaxX : WORD; MaxY : WORD; color : Ulong);
-PROCEDURE p96WriteTrueColorData(tci : pTrueColorInfo; SrcX : WORD; SrcY : WORD; rp : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD);
-PROCEDURE p96ReadTrueColorData(tci : pTrueColorInfo; DestX : WORD; DestY : WORD; rp : pRastPort; SrcX : WORD; SrcY : WORD; SizeX : WORD; SizeY : WORD);
-FUNCTION p96PIP_OpenTagList(Tags : pTagItem) : pWindow;
-FUNCTION p96PIP_Close(Window : pWindow) : BOOLEAN;
-FUNCTION p96PIP_SetTagList(Window : pWindow; Tags : pTagItem) : LONGINT;
-FUNCTION p96PIP_GetTagList(Window : pWindow; Tags : pTagItem) : LONGINT;
-FUNCTION p96GetRTGDataTagList(Tags : pTagItem) : LONGINT;
-FUNCTION p96GetBoardDataTagList(Board : Ulong; Tags : pTagItem) : LONGINT;
-FUNCTION p96EncodeColor(RGBFormat : RGBFTYPE; Color : Ulong) : Ulong;
-
+FUNCTION p96AllocBitMap(SizeX : Ulong location 'd0'; SizeY : Ulong location 'd1'; Depth : Ulong location 'd2'; Flags : Ulong location 'd3'; Friend : pBitMap location 'a0'; RGBFormat : RGBFTYPE location 'd7') : pBitMap; syscall P96Base 030;
+PROCEDURE p96FreeBitMap(BitMap : pBitMap location 'a0'); syscall P96Base 036;
+FUNCTION p96GetBitMapAttr(BitMap : pBitMap location 'a0'; Attribute : Ulong location 'd0') : Ulong; syscall P96Base 042;
+FUNCTION p96LockBitMap(BitMap : pBitMap location 'a0'; Buffer : pCHAR location 'a1'; Size : Ulong location 'd0') : LONGINT; syscall P96Base 048;
+PROCEDURE p96UnlockBitMap(BitMap : pBitMap location 'a0'; Lock : LONGINT location 'd0'); syscall P96Base 054;
+FUNCTION p96BestModeIDTagList(Tags : pTagItem location 'a0') : Ulong; syscall P96Base 060;
+FUNCTION p96RequestModeIDTagList(Tags : pTagItem location 'a0') : Ulong; syscall P96Base 066;
+FUNCTION p96AllocModeListTagList(Tags : pTagItem location 'a0') : pList; syscall P96Base 072;
+PROCEDURE p96FreeModeList(List : pList location 'a0'); syscall P96Base 078;
+FUNCTION p96GetModeIDAttr(Mode : Ulong location 'd0'; Attribute : Ulong location 'd1') : Ulong; syscall P96Base 084;
+FUNCTION p96OpenScreenTagList(Tags : pTagItem location 'a0') : pScreen; syscall P96Base 090;
+FUNCTION p96CloseScreen(Screen : pScreen location 'a0') : wordbool; syscall P96Base 096;
+PROCEDURE p96WritePixelArray(ri : pRenderInfo location 'a0'; SrcX : WORD location 'd0'; SrcY : WORD location 'd1'; rp : pRastPort location 'a1'; DestX : WORD location 'd2'; DestY : WORD location 'd3'; SizeX : WORD location 'd4'; SizeY : WORD location 'd5'); syscall P96Base 102;
+PROCEDURE p96ReadPixelArray(ri : pRenderInfo location 'a0'; DestX : WORD location 'd0'; DestY : WORD location 'd1'; rp : pRastPort location 'a1'; SrcX : WORD location 'd2'; SrcY : WORD location 'd3'; SizeX : WORD location 'd4'; SizeY : WORD location 'd5'); syscall P96Base 108;
+FUNCTION p96WritePixel(rp : pRastPort location 'a1'; x : WORD location 'd0'; y : WORD location 'd1'; color : Ulong location 'd2') : Ulong; syscall P96Base 114;
+FUNCTION p96ReadPixel(rp : pRastPort location 'a1'; x : WORD location 'd0'; y : WORD location 'd1') : Ulong; syscall P96Base 120;
+PROCEDURE p96RectFill(rp : pRastPort location 'a1'; MinX : WORD location 'd0'; MinY : WORD location 'd1'; MaxX : WORD location 'd2'; MaxY : WORD location 'd3'; color : Ulong location 'd4'); syscall P96Base 126;
+PROCEDURE p96WriteTrueColorData(tci : pTrueColorInfo location 'a0'; SrcX : WORD location 'd0'; SrcY : WORD location 'd1'; rp : pRastPort location 'a1'; DestX : WORD location 'd2'; DestY : WORD location 'd3'; SizeX : WORD location 'd4'; SizeY : WORD location 'd5'); syscall P96Base 132;
+PROCEDURE p96ReadTrueColorData(tci : pTrueColorInfo location 'a0'; DestX : WORD location 'd0'; DestY : WORD location 'd1'; rp : pRastPort location 'a1'; SrcX : WORD location 'd2';  SrcY : WORD location 'd3'; SizeX : WORD location 'd4'; SizeY : WORD location 'd5'); syscall P96Base 138;
+FUNCTION p96PIP_OpenTagList(Tags : pTagItem location 'a0') : pWindow; syscall P96Base 144;
+FUNCTION p96PIP_Close(Window : pWindow location 'a0') : wordbool; syscall P96Base 150;
+FUNCTION p96PIP_SetTagList(Window : pWindow location 'a0'; Tags : pTagItem location 'a1') : LONGINT; syscall P96Base 156;
+FUNCTION p96PIP_GetTagList(Window : pWindow location 'a0'; Tags : pTagItem location 'a1') : LONGINT; syscall P96Base 162;
+FUNCTION p96GetRTGDataTagList(Tags : pTagItem location 'a0') : LONGINT; syscall P96Base 180;
+FUNCTION p96GetBoardDataTagList(Board : Ulong location 'd0'; Tags : pTagItem location 'a0') : LONGINT; syscall P96Base 186;
+FUNCTION p96EncodeColor(RGBFormat : RGBFTYPE location 'd0'; Color : Ulong location 'd1') : Ulong; syscall P96Base 192;
 {
  Functions and procedures with array of const go here
 }
@@ -466,367 +461,6 @@ amsgbox,
 tagsarray;
 
 
-FUNCTION p96AllocBitMap(SizeX : Ulong; SizeY : Ulong; Depth : Ulong; Flags : Ulong; Friend : pBitMap; RGBFormat : RGBFTYPE) : pBitMap;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  SizeX,D0
-        MOVE.L  SizeY,D1
-        MOVE.L  Depth,D2
-        MOVE.L  Flags,D3
-        MOVEA.L Friend,A0
-        MOVE.L  RGBFormat,D7
-        MOVEA.L P96Base,A6
-        JSR     -030(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE p96FreeBitMap(BitMap : pBitMap);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L BitMap,A0
-        MOVEA.L P96Base,A6
-        JSR     -036(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION p96GetBitMapAttr(BitMap : pBitMap; Attribute : Ulong) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L BitMap,A0
-        MOVE.L  Attribute,D0
-        MOVEA.L P96Base,A6
-        JSR     -042(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96LockBitMap(BitMap : pBitMap; Buffer : pCHAR; Size : Ulong) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L BitMap,A0
-        MOVEA.L Buffer,A1
-        MOVE.L  Size,D0
-        MOVEA.L P96Base,A6
-        JSR     -048(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE p96UnlockBitMap(BitMap : pBitMap; Lock : LONGINT);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L BitMap,A0
-        MOVE.L  Lock,D0
-        MOVEA.L P96Base,A6
-        JSR     -054(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION p96BestModeIDTagList(Tags : pTagItem) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -060(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96RequestModeIDTagList(Tags : pTagItem) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -066(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96AllocModeListTagList(Tags : pTagItem) : pList;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -072(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE p96FreeModeList(List : pList);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L List,A0
-        MOVEA.L P96Base,A6
-        JSR     -078(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION p96GetModeIDAttr(Mode : Ulong; Attribute : Ulong) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Mode,D0
-        MOVE.L  Attribute,D1
-        MOVEA.L P96Base,A6
-        JSR     -084(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96OpenScreenTagList(Tags : pTagItem) : pScreen;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -090(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96CloseScreen(Screen : pScreen) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Screen,A0
-        MOVEA.L P96Base,A6
-        JSR     -096(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-PROCEDURE p96WritePixelArray(ri : pRenderInfo; SrcX : WORD; SrcY : WORD; rp : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ri,A0
-        MOVE.L  SrcX,D0
-        MOVE.L  SrcY,D1
-        MOVEA.L rp,A1
-        MOVE.L  DestX,D2
-        MOVE.L  DestY,D3
-        MOVE.L  SizeX,D4
-        MOVE.L  SizeY,D5
-        MOVEA.L P96Base,A6
-        JSR     -102(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE p96ReadPixelArray(ri : pRenderInfo; DestX : WORD; DestY : WORD; rp : pRastPort; SrcX : WORD; SrcY : WORD; SizeX : WORD; SizeY : WORD);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ri,A0
-        MOVE.L  DestX,D0
-        MOVE.L  DestY,D1
-        MOVEA.L rp,A1
-        MOVE.L  SrcX,D2
-        MOVE.L  SrcY,D3
-        MOVE.L  SizeX,D4
-        MOVE.L  SizeY,D5
-        MOVEA.L P96Base,A6
-        JSR     -108(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION p96WritePixel(rp : pRastPort; x : WORD; y : WORD; color : Ulong) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L rp,A1
-        MOVE.L  x,D0
-        MOVE.L  y,D1
-        MOVE.L  color,D2
-        MOVEA.L P96Base,A6
-        JSR     -114(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96ReadPixel(rp : pRastPort; x : WORD; y : WORD) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L rp,A1
-        MOVE.L  x,D0
-        MOVE.L  y,D1
-        MOVEA.L P96Base,A6
-        JSR     -120(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE p96RectFill(rp : pRastPort; MinX : WORD; MinY : WORD; MaxX : WORD; MaxY : WORD; color : Ulong);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L rp,A1
-        MOVE.L  MinX,D0
-        MOVE.L  MinY,D1
-        MOVE.L  MaxX,D2
-        MOVE.L  MaxY,D3
-        MOVE.L  color,D4
-        MOVEA.L P96Base,A6
-        JSR     -126(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE p96WriteTrueColorData(tci : pTrueColorInfo; SrcX : WORD; SrcY : WORD; rp : pRastPort; DestX : WORD; DestY : WORD; SizeX : WORD; SizeY : WORD);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L tci,A0
-        MOVE.L  SrcX,D0
-        MOVE.L  SrcY,D1
-        MOVEA.L rp,A1
-        MOVE.L  DestX,D2
-        MOVE.L  DestY,D3
-        MOVE.L  SizeX,D4
-        MOVE.L  SizeY,D5
-        MOVEA.L P96Base,A6
-        JSR     -132(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE p96ReadTrueColorData(tci : pTrueColorInfo; DestX : WORD; DestY : WORD; rp : pRastPort; SrcX : WORD; SrcY : WORD; SizeX : WORD; SizeY : WORD);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L tci,A0
-        MOVE.L  DestX,D0
-        MOVE.L  DestY,D1
-        MOVEA.L rp,A1
-        MOVE.L  SrcX,D2
-        MOVE.L  SrcY,D3
-        MOVE.L  SizeX,D4
-        MOVE.L  SizeY,D5
-        MOVEA.L P96Base,A6
-        JSR     -138(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION p96PIP_OpenTagList(Tags : pTagItem) : pWindow;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -144(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96PIP_Close(Window : pWindow) : BOOLEAN;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Window,A0
-        MOVEA.L P96Base,A6
-        JSR     -150(A6)
-        MOVEA.L (A7)+,A6
-        TST.W   D0
-        BEQ.B   @end
-        MOVEQ   #1,D0
-  @end: MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96PIP_SetTagList(Window : pWindow; Tags : pTagItem) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Window,A0
-        MOVEA.L Tags,A1
-        MOVEA.L P96Base,A6
-        JSR     -156(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96PIP_GetTagList(Window : pWindow; Tags : pTagItem) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Window,A0
-        MOVEA.L Tags,A1
-        MOVEA.L P96Base,A6
-        JSR     -162(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96GetRTGDataTagList(Tags : pTagItem) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -180(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96GetBoardDataTagList(Board : Ulong; Tags : pTagItem) : LONGINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Board,D0
-        MOVEA.L Tags,A0
-        MOVEA.L P96Base,A6
-        JSR     -186(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION p96EncodeColor(RGBFormat : RGBFTYPE; Color : Ulong) : Ulong;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  RGBFormat,D0
-        MOVE.L  Color,D1
-        MOVEA.L P96Base,A6
-        JSR     -192(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
 
 
 {

packages/amunits/src/otherlibs/ptreplay.pas

@@ -31,11 +31,6 @@
 
 }
 
-{$I useamigasmartlink.inc}
-{$ifdef use_amiga_smartlink}
-   {$smartlink on}
-{$endif use_amiga_smartlink}
-
 UNIT ptreplay;
 
 INTERFACE
@@ -66,32 +61,32 @@ USES Exec;
 
 VAR PTReplayBase : pLibrary;
 
-FUNCTION PTLoadModule(name : pCHAR) : pModule;
-PROCEDURE PTUnloadModule(module : pModule);
-FUNCTION PTPlay(module : pModule) : ULONG;
-FUNCTION PTStop(module : pModule) : ULONG;
-FUNCTION PTPause(module : pModule) : ULONG;
-FUNCTION PTResume(module : pModule) : ULONG;
-PROCEDURE PTFade(module : pModule; speed : BYTE);
-PROCEDURE PTSetVolume(module : pModule; vol : BYTE);
-FUNCTION PTSongPos(module : pModule) : BYTE;
-FUNCTION PTSongLen(module : pModule) : BYTE;
-FUNCTION PTSongPattern(module : pModule; Pos : WORD) : BYTE;
-FUNCTION PTPatternPos(Module : pModule) : BYTE;
-FUNCTION PTPatternData(Module : pModule; Pattern : BYTE; Row : BYTE) : POINTER;
-PROCEDURE PTInstallBits(Module : pModule; Restart : SHORTINT; NextPattern : SHORTINT; NextRow : SHORTINT; Fade : SHORTINT);
-FUNCTION PTSetupMod(ModuleFile : POINTER) : pModule;
-PROCEDURE PTFreeMod(Module : pModule);
-PROCEDURE PTStartFade(Module : pModule; speed : BYTE);
-PROCEDURE PTOnChannel(Module : pModule; Channels : SHORTINT);
-PROCEDURE PTOffChannel(Module : pModule; Channels : SHORTINT);
-PROCEDURE PTSetPos(Module : pModule; Pos : BYTE);
-PROCEDURE PTSetPri(Pri : SHORTINT);
-FUNCTION PTGetPri : SHORTINT;
-FUNCTION PTGetChan : SHORTINT;
-FUNCTION PTGetSample(Module : pModule; Nr : smallint) : pPTSample;
-
-FUNCTION PTLoadModule(name : string) : pModule;
+FUNCTION PTLoadModule(name : pCHAR location 'a0') : pModule; syscall PTReplayBase 030;
+PROCEDURE PTUnloadModule(module : pModule location 'a0'); syscall PTReplayBase 036;
+FUNCTION PTPlay(module : pModule location 'a0') : ULONG; syscall PTReplayBase 042;
+FUNCTION PTStop(module : pModule location 'a0') : ULONG; syscall PTReplayBase 048;
+FUNCTION PTPause(module : pModule location 'a0') : ULONG; syscall PTReplayBase 054;
+FUNCTION PTResume(module : pModule location 'a0') : ULONG; syscall PTReplayBase 060;
+PROCEDURE PTFade(module : pModule location 'a0'; speed : BYTE location 'd0'); syscall PTReplayBase 066;
+PROCEDURE PTSetVolume(module : pModule location 'a0'; vol : BYTE location 'd0'); syscall PTReplayBase 072;
+FUNCTION PTSongPos(module : pModule location 'a0') : BYTE; syscall PTReplayBase 078;
+FUNCTION PTSongLen(module : pModule location 'a0') : BYTE; syscall PTReplayBase 084;
+FUNCTION PTSongPattern(module : pModule location 'a0'; Pos : WORD location 'd0') : BYTE; syscall PTReplayBase 090;
+FUNCTION PTPatternPos(Module : pModule location 'a0') : BYTE; syscall PTReplayBase 096;
+FUNCTION PTPatternData(Module : pModule location 'a0'; Pattern : BYTE location 'd0'; Row : BYTE location 'd1') : POINTER; syscall PTReplayBase 102;
+PROCEDURE PTInstallBits(Module : pModule location 'a0'; Restart : SHORTINT location 'd0'; NextPattern : SHORTINT location 'd1'; NextRow : SHORTINT location 'd2'; Fade : SHORTINT location 'd3'); syscall PTReplayBase 108;
+FUNCTION PTSetupMod(ModuleFile : POINTER location 'a0') : pModule; syscall PTReplayBase 114;
+PROCEDURE PTFreeMod(Module : pModule location 'a0'); syscall PTReplayBase 120;
+PROCEDURE PTStartFade(Module : pModule location 'a0'; speed : BYTE location 'd0'); syscall PTReplayBase 126;
+PROCEDURE PTOnChannel(Module : pModule location 'a0'; Channels : SHORTINT location 'd0'); syscall PTReplayBase 132;
+PROCEDURE PTOffChannel(Module : pModule location 'a0'; Channels : SHORTINT location 'd0'); syscall PTReplayBase 138;
+PROCEDURE PTSetPos(Module : pModule location 'a0'; Pos : BYTE location 'd0'); syscall PTReplayBase 144;
+PROCEDURE PTSetPri(Pri : SHORTINT location 'd0'); syscall PTReplayBase 150;
+FUNCTION PTGetPri : SHORTINT; syscall PTReplayBase 156;
+FUNCTION PTGetChan : SHORTINT; syscall PTReplayBase 162;
+FUNCTION PTGetSample(Module : pModule location 'a0'; Nr : smallint location 'd0') : pPTSample; syscall PTReplayBase 168;
+
+FUNCTION PTLoadModule(const name : String) : pModule;
 
 {You can remove this include and use a define instead}
 {$I useautoopenlib.inc}
@@ -105,305 +100,18 @@ var
 
 IMPLEMENTATION
 
-uses
 {$ifndef dont_use_openlib}
-amsgbox,
+uses
+  amsgbox;
 {$endif dont_use_openlib}
-pastoc;
-
-FUNCTION PTLoadModule(name : pCHAR) : pModule;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L name,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -030(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE PTUnloadModule(module : pModule);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -036(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION PTPlay(module : pModule) : ULONG;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -042(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTStop(module : pModule) : ULONG;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -048(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTPause(module : pModule) : ULONG;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -054(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTResume(module : pModule) : ULONG;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -060(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE PTFade(module : pModule; speed : BYTE);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVE.L  speed,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -066(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE PTSetVolume(module : pModule; vol : BYTE);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVE.L  vol,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -072(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION PTSongPos(module : pModule) : BYTE;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -078(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTSongLen(module : pModule) : BYTE;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -084(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTSongPattern(module : pModule; Pos : WORD) : BYTE;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L module,A0
-        MOVE.L  Pos,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -090(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTPatternPos(Module : pModule) : BYTE;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -096(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTPatternData(Module : pModule; Pattern : BYTE; Row : BYTE) : POINTER;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.L  Pattern,D0
-        MOVE.L  Row,D1
-        MOVEA.L PTReplayBase,A6
-        JSR     -102(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE PTInstallBits(Module : pModule; Restart : SHORTINT; NextPattern : SHORTINT; NextRow : SHORTINT; Fade : SHORTINT);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.L  Restart,D0
-        MOVE.L  NextPattern,D1
-        MOVE.L  NextRow,D2
-        MOVE.L  Fade,D3
-        MOVEA.L PTReplayBase,A6
-        JSR     -108(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION PTSetupMod(ModuleFile : POINTER) : pModule;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L ModuleFile,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -114(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-PROCEDURE PTFreeMod(Module : pModule);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVEA.L PTReplayBase,A6
-        JSR     -120(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE PTStartFade(Module : pModule; speed : BYTE);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.L  speed,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -126(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE PTOnChannel(Module : pModule; Channels : SHORTINT);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.L  Channels,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -132(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE PTOffChannel(Module : pModule; Channels : SHORTINT);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.L  Channels,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -138(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE PTSetPos(Module : pModule; Pos : BYTE);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.L  Pos,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -144(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-PROCEDURE PTSetPri(Pri : SHORTINT);
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVE.L  Pri,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -150(A6)
-        MOVEA.L (A7)+,A6
-  END;
-END;
-
-FUNCTION PTGetPri : SHORTINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L PTReplayBase,A6
-        JSR     -156(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTGetChan : SHORTINT;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L PTReplayBase,A6
-        JSR     -162(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.B  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTGetSample(Module : pModule; Nr : smallint) : pPTSample;
-BEGIN
-  ASM
-        MOVE.L  A6,-(A7)
-        MOVEA.L Module,A0
-        MOVE.W  Nr,D0
-        MOVEA.L PTReplayBase,A6
-        JSR     -168(A6)
-        MOVEA.L (A7)+,A6
-        MOVE.L  D0,@RESULT
-  END;
-END;
-
-FUNCTION PTLoadModule(name : string) : pModule;
+
+
+FUNCTION PTLoadModule(const name : string) : pModule;
+var
+  s: RawByteString;
 begin
-    PTLoadModule := PTLoadModule(pas2c(name));
+  s:=name;
+  PTLoadModule := PTLoadModule(PChar(s));
 end;
 
 const
@@ -489,9 +197,3 @@ begin
 
 
 END. (* UNIT PTREPLAY *)
-
-
-
-
-
-

packages/amunits/src/otherlibs/render.pas

@@ -42,7 +42,7 @@ USES Exec,utility,agraphics;
 VAR RenderBase : pLibrary;
 
 type
-    pPLANEPTR = ^PLANEPTR;
+    pPLANEPTR = ^TPLANEPTR;
 
 const
     RENDERNAME : PChar = 'render.library';

packages/amunits/src/utilunits/amsgbox.pas

@@ -28,13 +28,12 @@ unit AMsgBox;
 interface
 
 
-
-FUNCTION MessageBox(tit,txt,gad:string) : LONGint;
-function MessageBox(tit,txt,gad:pchar):longint;
+FUNCTION MessageBox(const tit,txt,gad:RawByteString): LongInt;
+FUNCTION MessageBox(const tit,txt,gad:string): LongInt;
+function MessageBox(const tit,txt,gad:pchar): LongInt;
 
 implementation
 
-uses pastoc;
 type
  pEasyStruct = ^tEasyStruct;
    tEasyStruct = record
@@ -48,21 +47,26 @@ type
 
 FUNCTION EasyRequestArgs(window : pointer location 'a0'; easyStruct : pEasyStruct location 'a1'; idcmpPtr : longint location 'a2'; args : POINTER location 'a3') : LONGINT; syscall _IntuitionBase 588;
 
-FUNCTION MessageBox(tit,txt,gad:string) : LONGint;
+FUNCTION MessageBox(const tit,txt,gad:RawByteString): LongInt;
+begin
+  MessageBox:=MessageBox(PChar(tit),PChar(txt),PChar(gad));
+end;
+
+FUNCTION MessageBox(const tit,txt,gad:string) : LONGint;
 begin
-    MessageBox := MessageBox(pas2c(tit),pas2c(txt),pas2c(gad));
+  MessageBox := MessageBox(PChar(RawByteString(tit)),PChar(RawByteString(txt)),PChar(RawByteString(gad)));
 end;
 
-FUNCTION MessageBox(tit,txt,gad:pchar) : LONGint;
+FUNCTION MessageBox(const tit,txt,gad:pchar) : LONGint;
 VAR
   MyStruct : tEasyStruct;
 BEGIN
- MyStruct.es_StructSize:=SizeOf(tEasyStruct);
- MyStruct.es_Flags:=0;
- MyStruct.es_Title:=(tit);
- MyStruct.es_TextFormat:=(txt);
- MyStruct.es_GadgetFormat:=(gad);
- MessageBox := EasyRequestArgs(nil,@MyStruct,0,NIL);
+  MyStruct.es_StructSize:=SizeOf(tEasyStruct);
+  MyStruct.es_Flags:=0;
+  MyStruct.es_Title:=(tit);
+  MyStruct.es_TextFormat:=(txt);
+  MyStruct.es_GadgetFormat:=(gad);
+  MessageBox := EasyRequestArgs(nil,@MyStruct,0,NIL);
 END;
 
 end.

packages/amunits/src/utilunits/doublebuffer.pas

@@ -181,7 +181,7 @@ var
     bm1,
     bm2 : pBitMap;
     rp : pRastPort;
-    Temp : Array [0..7] of PLANEPTR;
+    Temp : Array [0..7] of TPLANEPTR;
 begin
     s := w^.WScreen;
     rp := w^.RPort;

packages/arosunits/src/amigados.pas

@@ -13,7 +13,6 @@
 
  **********************************************************************}
 {
- missing elf.h // Elfheader
  BSTR Funktions
  
  defines:
@@ -1936,8 +1935,316 @@ const
   ERROR_BROKEN_PIPE = 400;  // An attempt to write on a pipe without any reader has been made
   ERROR_WOULD_BLOCK = 401;  // A Read() or a Write() on a file opened with the FMF_NONBLOCK flag would block
   ERROR_INTERRUPTED = 402;  // The I/O file operation has been interrupted for some reason  
-{$endif}
+  
+// elf.h  
+  
+type
+  //*
+  //* Define one of ELF_64BIT or ELF_32BIT in your code if you want to enforce specific
+  //* version of ELF structures. Otherwize it fails back to your native machine's size.
+  //*  
+  {$IFDEF ELF_64BIT}
+  {$define elf_ptr_t}
+  elf_ptr_t             = UQUAD;
+  elf_uintptr_t         = UQUAD;
+  elf_intptr_t          = QUAD;
+  {$ENDIF}
+
+  {$IFDEF ELF_32BIT}
+  {$define elf_ptr_t}
+  elf_ptr_t             = ULONG;
+  elf_uintptr_t         = ULONG;
+  elf_intptr_t          = LONG;
+  {$ENDIF}
+
+  {$IFNDEF elf_ptr_t}
+  elf_ptr_t             = APTR;
+  elf_uintptr_t         = IPTR;
+  elf_intptr_t          = SIPTR;
+  {$ENDIF}
+
+
+Const
+  SHT_PROGBITS          =  1;
+  SHT_SYMTAB            =  2;
+  SHT_STRTAB            =  3;
+  SHT_RELA              =  4;
+  SHT_NOBITS            =  8;
+  SHT_REL               =  9;
+  SHT_SYMTAB_SHNDX      = 18;
+  SHT_ARM_ATTRIBUTES    = $70000003;
+  
+  ET_REL                =  1;
+  ET_EXEC               =  2;
+  
+  EM_386                =  3;
+  EM_68K                =  4;
+  EM_PPC                = 20;
+  EM_ARM                = 40;
+  EM_X86_64             = 62;     //* AMD x86-64 */
+  
+  R_386_NONE            = 0;
+  R_386_32              = 1;
+  R_386_PC32            = 2;
+
+  //* AMD x86-64 relocations.  */
+  R_X86_64_NONE         =  0;      //* No reloc */
+  R_X86_64_64           =  1;      //* Direct 64 bit  */
+  R_X86_64_PC32         =  2;      //* PC relative 32 bit signed */
+  R_X86_64_32           = 10;
+  R_X86_64_32S          = 11;
+  
+  R_68K_NONE            = 0;
+  R_68K_32              = 1;
+  R_68K_16              = 2;
+  R_68K_8               = 3;
+  R_68K_PC32            = 4;
+  R_68K_PC16            = 5;
+  R_68K_PC8             = 6;
+  
+  R_PPC_NONE            =   0;
+  R_PPC_ADDR32          =   1;
+  R_PPC_ADDR16_LO       =   4;
+  R_PPC_ADDR16_HA       =   6;
+  R_PPC_REL24           =  10;
+  R_PPC_REL32           =  26;
+  R_PPC_REL16_LO        = 250;
+  R_PPC_REL16_HA        = 252;
+  
+  R_ARM_NONE            =  0;
+  R_ARM_PC24            =  1;
+  R_ARM_ABS32           =  2;
+  R_ARM_CALL            = 28;
+  R_ARM_JUMP24          = 29;
+  R_ARM_TARGET1         = 38;
+  R_ARM_V4BX            = 40;
+  R_ARM_TARGET2         = 41;
+  R_ARM_PREL31          = 42;
+  R_ARM_MOVW_ABS_NC     = 43;
+  R_ARM_MOVT_ABS        = 44;
+  R_ARM_THM_CALL        = 10;
+  R_ARM_THM_JUMP24      = 30;
+  R_ARM_THM_MOVW_ABS_NC = 47;
+  R_ARM_THM_MOVT_ABS    = 48;
+ 
+  STT_NOTYPE            =  0;
+  STT_OBJECT            =  1;
+  STT_FUNC              =  2;
+  STT_SECTION           =  3;
+  STT_FILE              =  4;
+  STT_LOPROC            = 13;
+  STT_HIPROC            = 15;
+ 
+  STB_LOCAL             =  0;
+  STB_GLOBAL            =  1;
+  STB_WEAK              =  2;
+  STB_LOOS              = 10;
+  STB_GNU_UNIQUE        = 10;
+  STB_HIOS              = 12;
+  STB_LOPROC            = 13;
+  STB_HIPROC            = 15;
+ 
+  SHN_UNDEF             = 0;
+  SHN_LORESERVE         = $ff00;
+  SHN_ABS               = $fff1;
+  SHN_COMMON            = $fff2;
+  SHN_XINDEX            = $ffff;
+  SHN_HIRESERVE         = $ffff;
+ 
+  SHF_WRITE             = (1 shl 0);
+  SHF_ALLOC             = (1 shl 1);
+  SHF_EXECINSTR         = (1 shl 2);
+ 
+  //  ELF_ST_TYPE(i)    ((i) & 0x0F)
+ 
+  EI_VERSION            =  6;
+  EV_CURRENT            =  1;
+ 
+  EI_DATA               =  5;
+  ELFDATA2LSB           =  1;
+  ELFDATA2MSB           =  2;
+ 
+  EI_CLASS              =  4;
+  ELFCLASS32            =  1;
+  ELFCLASS64            =  2;             //* 64-bit objects */
+ 
+  EI_OSABI              =  7;
+  EI_ABIVERSION         =  8;
+ 
+  ELFOSABI_AROS         = 15;
+ 
+  PF_X                  = (1 shl 0);
+  
+  ATTR_VERSION_CURRENT  = $41;
 
+type
+  PElfHeader = ^TELFHeader;
+  TElfHeader = record
+    Ident:     array [0..16-1] of Byte;
+    Type_:     Word;
+    Machine:   Word;
+    Version:   LongWord;
+    Entry:     elf_ptr_t;
+    PhOff:     elf_uintptr_t;
+    ShOff:     elf_uintptr_t;
+    Flags:     LongWord;
+    EhSize:    Word;
+    PhentSize: Word;
+    PhNum:     Word;
+    ShentSize: Word;
+    ShNum:     Word;
+    ShStrndx:  Word;  
+  end;
+  
+  PSHeader  = ^TSHeader;
+  TSHeader = record
+    Name:      LongWord;
+    Type_:     LongWord;
+    Flags:     elf_uintptr_t ;
+    Addr:      elf_ptr_t     ;
+    Offset:    elf_uintptr_t ;
+    Size:      elf_uintptr_t ;
+    Link:      LongWord;
+    Info:      LongWord;
+    AddrAlign: elf_uintptr_t ;
+    EntSize:   elf_uintptr_t ;
+  end;
+  
+  {$DEFINE PT_LOAD}
+
+{$IFDEF ELF_64BIT}
+  TPHeader = record
+    Type_:  LongWord;
+    Flags:  LongWord;
+    Offset: elf_uintptr_t;
+    VAddr:  elf_ptr_t;
+    PAddr:  elf_ptr_t;  
+    Filesz: elf_uintptr_t;
+    Memsz:  elf_uintptr_t;
+    Align:  elf_uintptr_t;
+  end;
+  
+  TSymbol = record
+    Name:    LongWord; // Offset of the name string in the string table
+    Info:    Byte;     // What kind of symbol is this ? (global, variable, etc)
+    Other:   Byte;     // undefined                                        
+    ShIndex: Word;     // In which section is the symbol defined ?               
+    Value:   elf_uintptr_t ; // Varies; eg. the offset of the symbol in its hunk
+    Size:    elf_uintptr_t ; // How much memory does the symbol occupy    
+  end;
+
+  // 209 #define ELF_R_SYM(i)          (ULONG)((i) >> 32)
+  // 210 #define ELF_R_TYPE(i)         (ULONG)((i) & 0xffffffffULL)
+  // 211 #define ELF_R_INFO(sym, type) (((UQUAD)(sym) << 32) + (type))
+
+{$ELSE ELF_64BIT}
+  TPHeader = record
+    Type_:  LongWord;
+    Offset: LongWord;
+    VAddr:  elf_ptr_t;
+    PAddr:  elf_ptr_t;  
+    Filesz: LongWord;
+    Memsz:  LongWord;
+    Flags:  LongWord;
+    Align:  LongWord;
+  end;
+  
+  TSymbol = record
+    Name:    LongWord;       // Offset of the name string in the string table
+    Value:   elf_uintptr_t;  // Varies; eg. the offset of the symbol in its hunk
+    Size:    elf_uintptr_t;  // How much memory does the symbol occupy
+    Info:    Byte;           // What kind of symbol is this ? (global, variable, etc)
+    Other:   Byte;           // undefined
+    ShIndex: Word;           // In which section is the symbol defined?
+  end;
+  
+  // 237 #define ELF_R_SYM(val)        ((val) >> 8)
+  // 238 #define ELF_R_TYPE(val)       ((val) & 0xff)
+  // 239 #define ELF_R_INFO(sym, type) (((sym) << 8) + ((type) & 0xff))
+{$ENDIF}
+
+
+  // 243 #define ELF_S_BIND(val)         ((val) >> 4)
+  // 244 #define ELF_S_TYPE(val)         ((val) & 0xF)
+  // 245 #define ELF_S_INFO(bind, type)  (((bind) << 4) + ((type) & 0xF))
+
+  TRel = record
+    Offset: elf_uintptr_t;     // Address of the relocation relative to the section it refers to
+    Info:   elf_uintptr_t;     // Type of the relocation
+  end;
+
+  TRelA = record
+    Offset: elf_uintptr_t;     // Address of the relocation relative to the section it refers to
+    Info:   elf_uintptr_t;     // Type of the relocation
+    Addend: elf_uintptr_t;     // Constant addend used to compute value
+  end;
+
+
+  (*
+ 260 /* Note: the conversion below is not in line with ELF specification and is fixed in GNU binutils since 2008
+ 261  * See: https://sourceware.org/bugzilla/show_bug.cgi?id=5900
+ 262  */
+ 263 /* convert section header number to array index */
+ 264 /*#define SHINDEX(n) \
+ 265     ((n) < SHN_LORESERVE ? (n) : ((n) <= SHN_HIRESERVE ? 0 : (n) - (SHN_HIRESERVE + 1 - SHN_LORESERVE)))*/
+ 266 
+ 267 /* convert section header array index to section number */
+ 268 /*#define SHNUM(i) \
+ 269     ((i) < SHN_LORESERVE ? (i) : (i) + (SHN_HIRESERVE + 1 - SHN_LORESERVE))*/
+ 270 
+ 271 /* ARM-specific attributes section definitions follow */
+ 272 
+ 273 #define  
+  *)
+ 
+  TAttrs_Section = record
+    Size:   LongWord;
+    Vendor: array[0..0] of char;   // NULL-terminated name
+  end;                             // Vendor-specific subsections follow
+ 
+  TAttrs_SubSection = packed record
+    Tag: Byte;
+    Size: LongWord;  
+  end;
+
+const 
+  Tag_File                 = 1;
+  Tag_Section              = 2;
+  Tag_Symbol               = 3;
+  Tag_CPU_raw_name         = 4;
+  Tag_CPU_name             = 5;
+  Tag_CPU_arch             = 6;
+  Tag_FP_arch              = 10;
+  Tag_compatibility        = 32;
+  Tag_also_compatible_with = 65;
+  Tag_conformance          = 67;
+
+  // Tag_CPU_arch values
+  ELF_CPU_PREv4    = 0;
+  ELF_CPU_ARMv4    = 1;
+  ELF_CPU_ARMv4T   = 2;
+  ELF_CPU_ARMv5T   = 3;
+  ELF_CPU_ARMv5TE  = 4;
+  ELF_CPU_ARMv5TEJ = 5;
+  ELF_CPU_ARMv6    = 6;
+  ELF_CPU_ARMv6KZ  = 7;
+  ELF_CPU_ARMv6T2  = 8;
+  ELF_CPU_ARMv6K   = 9;
+  ELF_CPU_ARMv7    = 10;
+  ELF_CPU_ARM_v6M  = 11;
+  ELF_CPU_ARMv6SM  = 12;
+  ELF_CPU_ARMv7EM  = 13;
+
+  //* Tag_FP_arch values */
+  ELF_FP_None     = 0;
+  ELF_FP_v1       = 1;
+  ELF_FP_v2       = 2;
+  ELF_FP_v3       = 3;
+  ELF_FP_v3_Short = 4;
+  ELF_FP_v4       = 5;
+  ELF_FP_v4_Short = 6;  
+
+{$endif}
 
 
 procedure AbortPkt(Port: PMsgPort; Pkt: PDosPacket); syscall AOS_DOSBase 44;
@@ -1958,14 +2265,14 @@ function Cli: PCommandLineInterface; syscall AOS_DOSBase 82;
 function CliInitNewcli(Dp: PDosPacket): IPTR; syscall AOS_DOSBase 155;
 function CliInitRun(Dp: PDosPacket): IPTR; syscall AOS_DOSBase 156;
 function CompareDates(const Date1: PDateStamp; const Date2: PDateStamp): LongInt; syscall AOS_DOSBase 123;
-function CreateDir(const Name: STRPTR): BPTR; syscall AOS_DOSBase 20;
+function DOSCreateDir(const Name: STRPTR): BPTR; syscall AOS_DOSBase 20;
 function CreateNewProc(const Tags: PTagItem): PProcess; syscall AOS_DOSBase 83;
   //function CreateNewProcTagList(const Tags : PTagItem) : pProcess;
 function CreateProc(const Name: STRPTR; Pri: LongInt; SegList: BPTR; StackSize: LongInt): PMsgPort; syscall AOS_DOSBase 23;
 function CurrentDir(Lock: BPTR): BPTR; syscall AOS_DOSBase 21;
 function DateStamp(Date: PDateStamp): PDateStamp; syscall AOS_DOSBase 32;
 function DateToStr(Datetime: PDateTime): LongBool; syscall AOS_DOSBase 124;
-function DeleteFile(const Name: STRPTR): LongBool; syscall AOS_DOSBase 12;
+function DOSDeleteFile(const Name: STRPTR): LongBool; syscall AOS_DOSBase 12;
 function DeleteVar(const Name: STRPTR; Flags: LongWord): LongInt; syscall AOS_DOSBase 152;
 function DeviceProc(const Name: STRPTR): PMsgPort; syscall AOS_DOSBase 29;
 function DisplayError(FormstStr: STRPTR; Flags: LongWord; Args: APTR): LongInt; syscall AOS_DOSBase 81;
@@ -2117,6 +2424,20 @@ function CreateNewProcTags(const Tags: array of const): PProcess;
 function NewLoadSegTags(const File_: STRPTR; const Tags: array of const): BPTR;
 function SystemTags(const Command: STRPTR; const Tags: array of const): LongInt;
 
+// elf.h
+
+function ELF_ST_TYPE(i: LongWord): LongWord;
+{$ifdef ELF_64BIT}
+function ELF_R_SYM(i: QWord): QWord;
+function ELF_R_TYPE(i: QWord): QWord;
+function ELF_R_INFO(Sym: QWord; Type_: QWord): QWord;
+{$else}
+function ELF_R_SYM(i: LongWord): LongWord;
+function ELF_R_TYPE(i: LongWord): LongWord;
+function ELF_R_INFO(Sym: LongWord; Type_: LongWord): LongWord;
+{$endif}
+
+
 const
   BNULL = nil;
 
@@ -2127,7 +2448,43 @@ implementation
 
 uses
   tagsarray;
+
+function ELF_ST_TYPE(i: LongWord): LongWord;
+begin
+  Result := i and $0F;
+end;   
+
+{$ifdef ELF_64BIT}
+  function ELF_R_SYM(i: QWord): QWord;
+  begin
+    Result := i shr 32;
+  end;
+  
+  function ELF_R_TYPE(i: QWord): QWord;
+  begin
+    Result := i and $ffffffff;
+  end;
+  
+  function ELF_R_INFO(Sym: QWord; Type_: QWord): QWord;
+  begin
+    Result := Sym shl 32 + Type_;
+  end;
+{$else}
+  function ELF_R_SYM(i: LongWord): LongWord;
+  begin
+    Result := i shr 8;
+  end;
   
+  function ELF_R_TYPE(i: LongWord): LongWord;
+  begin
+    Result := i and $ff;
+  end;
+  
+  function ELF_R_INFO(Sym: LongWord; Type_: LongWord): LongWord;
+  begin
+    Result := Sym shl 8 + (Type_ and $ff);
+  end;
+{$endif}
   
 function AllocDosObjectTags(const Type_: LongWord; const Tags: array of const): APTR;
 var

packages/arosunits/src/exec.pas

@@ -38,6 +38,7 @@ type
   QUAD         = Int64;
   UQUAD        = QWord;
   IPTR         = NativeUInt;
+  SIPTR        = NativeInt;
   PIPTR        = ^IPTR;
   STRPTR       = PChar;
   CONST_STRPTR = PChar;  

packages/arosunits/src/mui.pas

@@ -530,16 +530,16 @@ uses
             ehn_Class : PIClass;
             ehn_Events : LongWord;
          end;
-{$else}         
+{$else}
        tMUI_EventHandlerNode = record
             ehn_Node : TNode;
             ehn_Flags : WORD;
             ehn_Object : PObject_;
             ehn_Class : PIClass;
             ehn_Events : LongWord;
-            ehn_Priority : BYTE;            
+            ehn_Priority : BYTE;
          end;
-{$endif}         
+{$endif}
        pMUI_EventHandlerNode = ^tMUI_EventHandlerNode;
     { flags for ehn_Flags  }
 
@@ -1508,12 +1508,12 @@ uses
      { MUI_MinMax structure holds information about minimum, maximum
        and default dimensions of an object.  }
        tMUI_MinMax = record
-            MinWidth : WORD;
-            MinHeight : WORD;
-            MaxWidth : WORD;
-            MaxHeight : WORD;
-            DefWidth : WORD;
-            DefHeight : WORD;
+            MinWidth : SmallInt;
+            MinHeight : SmallInt;
+            MaxWidth : SmallInt;
+            MaxHeight : SmallInt;
+            DefWidth : SmallInt;
+            DefHeight : SmallInt;
          end;
        pMUI_MinMax = ^tMUI_MinMax;
 
@@ -3469,7 +3469,7 @@ uses
 var
   MUIMasterBase : pLibrary;
 
-function MUI_NewObjectA(class_ : PChar; tags : pTagItem) : PObject_; syscall MUIMasterBase 5; 
+function MUI_NewObjectA(class_ : PChar; tags : pTagItem) : PObject_; syscall MUIMasterBase 5;
 procedure MUI_DisposeObject(obj : PObject_); syscall MUIMasterBase 6;
 function MUI_RequestA(app : Pointer; win : Pointer; flags : LONGBITS; title : PChar; gadgets : PChar; format : PChar; params : Pointer) : LongInt; syscall MUIMasterBase 7;
 function MUI_AllocAslRequest(typ : LongWord; tags : pTagItem) : Pointer; syscall MUIMasterBase 8;

packages/cdrom/src/cdrom.pp

@@ -20,12 +20,23 @@ unit cdrom;
 interface
 
 Type
+  // Frames are 1/75th of a second.
+  // To get the seconds of a track divide the frames by 75.
+  // TrackLen: Double; ...
+  // TrackLen := Frames / 75.
   TTocEntry = Record
     min, sec, frame : Integer;
   end;
   PTocEntry = ^TTocEntry;
 
+// Returns the High value to use in a loop. Each entry is the position of the end
+// of a track. For audio cd's the zero'th entry is not audio data. If an audio cd
+// has 10 songs then ReadCDToc will return 10 but there are 11 entries: 0..10.
+// You still need to use the zero'th entry to get the first track length:
+// Track1Length := TOC[1].frames = TOC[0].frames.
 Function ReadCDTOC(Device : String; Var CDTOC : Array of TTocEntry) : Integer;
+
+// Returns the number of devices placed in 'Devices'
 Function GetCDRomDevices(Var Devices : Array of string) : Integer;
 
 Implementation

packages/chm/src/chmfilewriter.pas

@@ -1144,11 +1144,13 @@ begin
    begin
      if fileexists(FTableOfContentsFileName) then
        begin
+         FreeAndNil(FTocStream);
          FTocStream:=TMemoryStream.Create;
          try
            FTocStream.loadfromfile(FTableOfContentsFilename);
-           writeln(ftableofcontentsfilename, ' ' ,ftocstream.size);
+           //writeln(ftableofcontentsfilename, ' ' ,ftocstream.size);
            FTocStream.Position:=0;
+           FreeAndNil(FToc);
            FToc:=TChmSiteMap.Create(sttoc);
            FToc.loadfromstream(FTocStream);
            ftoc.savetofile('bla.something');
@@ -1167,10 +1169,12 @@ begin
    begin
      if fileexists(FIndexFileName) then
        begin
+        FreeAndNil(FIndexStream);
         FIndexStream:=TMemoryStream.Create;
         try
           FIndexStream.LoadFromFile(FIndexFileName);
           FIndexStream.Position:=0;
+          FreeAndNil(FIndex);
           FIndex:=TChmSiteMap.Create(stindex);
           FIndex.loadfromfile(FIndexFileName);
         except

packages/chm/src/chmsitemap.pas

@@ -351,15 +351,22 @@ var
 begin
   if Assigned(FHTMLParser) then FHTMLParser.Free;
   TmpStream := TMemoryStream.Create;
-  TmpStream.LoadFromFile(AFileName);
-  SetLength(Buffer, TmpStream.Size);
-  TmpStream.Position := 0;
-  TmpStream.Read(Buffer[1], TmpStream.Size);
+  try
+    TmpStream.LoadFromFile(AFileName);
+    SetLength(Buffer, TmpStream.Size);
+    TmpStream.Position := 0;
+    TmpStream.Read(Buffer[1], TmpStream.Size);
+  finally
+    TmpStream.Free;
+  end;
   FHTMLParser := THTMLParser.Create(Buffer);
-  FHTMLParser.OnFoundTag := @FoundTag;
-  FHTMLParser.OnFoundText := @FoundText;
-  FHTMLParser.Exec;
-  FreeAndNil(FHTMLParser);
+  try
+    FHTMLParser.OnFoundTag := @FoundTag;
+    FHTMLParser.OnFoundText := @FoundText;
+    FHTMLParser.Exec;
+  finally
+    FreeAndNil(FHTMLParser);
+  end;
 end;
 
 procedure TChmSiteMap.LoadFromStream(AStream: TStream);

packages/chm/src/chmwriter.pas

@@ -1533,7 +1533,7 @@ begin
   FURLSTRStream.Free;
   FURLTBLStream.Free;
   FFiftiMainStream.Free;
-  FIDXHdrStream.Create;
+  FIDXHdrStream.Free;
   SpareString.free;
   SpareUrlStr.free;
   FAvlUrlStr.FreeAndClear;

packages/chm/src/fasthtmlparser.pas

@@ -1,22 +1,5 @@
-{ Copyright (C) <2005> <Andrew Haines> fasthtmlparser.pas
-
-  This library is free software; you can redistribute it and/or modify it
-  under the terms of the GNU Library General Public License as published by
-  the Free Software Foundation; either version 2 of the License, or (at your
-  option) any later version.
-
-  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. See the GNU Library General Public License
-  for more details.
-
-  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., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
-}
 {
-  See the file COPYING.FPC, included in this distribution,
-  for details about the copyright.
+  See the section LICENSE/TERMS below for details about the copyright.
 }
 // TODO:
 {

packages/dblib/src/dblib.pp

@@ -173,6 +173,7 @@ const
 
   // Error codes:
   SYBEFCON = 20002;      // SQL Server connection failed
+  SYBESMSG = 20018;      // General SQL Server error: Check messages from the SQL Server.
 
 type
   PLOGINREC=Pointer;
@@ -275,8 +276,8 @@ type
     str: array[0..DBMAXCHAR-1] of AnsiChar;
   end;
 
-  DBERRHANDLE_PROC=function(dbproc: PDBPROCESS; severity, dberr, oserr:INT; dberrstr, oserrstr:PChar):INT; cdecl;
-  DBMSGHANDLE_PROC=function(dbproc: PDBPROCESS; msgno: DBINT; msgstate, severity:INT; msgtext, srvname, procname:PChar; line:DBUSMALLINT):INT; cdecl;
+  DBERRHANDLE_PROC=function(dbproc: PDBPROCESS; severity, dberr, oserr:INT; dberrstr, oserrstr:PAnsiChar):INT; cdecl;
+  DBMSGHANDLE_PROC=function(dbproc: PDBPROCESS; msgno: DBINT; msgstate, severity:INT; msgtext, srvname, procname:PAnsiChar; line:DBUSMALLINT):INT; cdecl;
 
   {$IFDEF ntwdblib}
     {$PACKRECORDS 2}
@@ -305,27 +306,27 @@ var
   DBLibInit: boolean=false; //was dbinit() already called ?
 
 {$IFNDEF LOAD_DYNAMICALLY}
-  function dbinit():{$IFDEF freetds}RETCODE{$ELSE}PChar{$ENDIF}; cdecl; external DBLIBDLL;
+  function dbinit():{$IFDEF freetds}RETCODE{$ELSE}PAnsiChar{$ENDIF}; cdecl; external DBLIBDLL;
   function dblogin():PLOGINREC; cdecl; external DBLIBDLL;
-  function dbsetlname(login:PLOGINREC; value:PChar; which:INT):RETCODE; cdecl; external DBLIBDLL;
+  function dbsetlname(login:PLOGINREC; value:PAnsiChar; which:INT):RETCODE; cdecl; external DBLIBDLL;
   function dbsetlogintime(seconds:INT):RETCODE; cdecl; external DBLIBDLL;
   function dbsettime(seconds:INT):RETCODE; cdecl; external DBLIBDLL;
   function dberrhandle(handler:DBERRHANDLE_PROC):DBERRHANDLE_PROC; cdecl; external DBLIBDLL;
   function dbmsghandle(handler:DBMSGHANDLE_PROC):DBMSGHANDLE_PROC; cdecl; external DBLIBDLL;
-  function dbsetopt(dbproc:PDBPROCESS; option: INT; param:PChar {$IFDEF freetds};int_param:INT{$ENDIF}):RETCODE; cdecl; external DBLIBDLL;
-  function dbuse(dbproc:PDBPROCESS; dbname:PChar):RETCODE; cdecl; external DBLIBDLL;
-  function dbcmd(dbproc:PDBPROCESS; cmdstring:PChar):RETCODE; cdecl; external DBLIBDLL;
+  function dbsetopt(dbproc:PDBPROCESS; option: INT; param:PAnsiChar {$IFDEF freetds};int_param:INT{$ENDIF}):RETCODE; cdecl; external DBLIBDLL;
+  function dbuse(dbproc:PDBPROCESS; dbname:PAnsiChar):RETCODE; cdecl; external DBLIBDLL;
+  function dbcmd(dbproc:PDBPROCESS; cmdstring:PAnsiChar):RETCODE; cdecl; external DBLIBDLL;
   function dbcmdrow(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
   function dbsqlexec(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
   function dbresults(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
   function dbmorecmds(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
   function dbnextrow(dbproc:PDBPROCESS):STATUS; cdecl; external DBLIBDLL;
   function dbnumcols(dbproc:PDBPROCESS):INT; cdecl; external DBLIBDLL;
-  function dbcolname(dbproc:PDBPROCESS; column:INT):PChar; cdecl; external DBLIBDLL;
+  function dbcolname(dbproc:PDBPROCESS; column:INT):PAnsiChar; cdecl; external DBLIBDLL;
   function dbcoltype(dbproc:PDBPROCESS; column:INT):INT; cdecl; external DBLIBDLL;
   function dbcollen(dbproc:PDBPROCESS; column:INT):DBINT; cdecl; external DBLIBDLL;
   function dbcolinfo(dbproc:PDBPROCESS; typ:INT; column:DBINT; computeid:DBINT; dbcol:PDBCOL):RETCODE; cdecl; external DBLIBDLL;
-  function dbprtype(token:INT):PChar; cdecl; external DBLIBDLL;
+  function dbprtype(token:INT):PAnsiChar; cdecl; external DBLIBDLL;
   function dbdatlen(dbproc:PDBPROCESS; column:INT):DBINT; cdecl; external DBLIBDLL;
   function dbdata(dbproc:PDBPROCESS; column:INT):PByte; cdecl; external DBLIBDLL;
   function dbwillconvert(srctype, desttype: INT):{$IFDEF freetds}DBBOOL{$ELSE}BOOL{$ENDIF}; cdecl; external DBLIBDLL;
@@ -340,41 +341,41 @@ var
   procedure dbfreelogin(login:PLOGINREC); cdecl; external DBLIBDLL {$IFDEF freetds}name 'dbloginfree'{$ENDIF};
   procedure dbexit(); cdecl; external DBLIBDLL;
   {$IFDEF ntwdblib}
-  function dbopen(login:PLOGINREC; servername:PChar):PDBPROCESS; cdecl; external DBLIBDLL;
+  function dbopen(login:PLOGINREC; servername:PAnsiChar):PDBPROCESS; cdecl; external DBLIBDLL;
   function dbclose(dbproc:PDBPROCESS):RETCODE; cdecl; external DBLIBDLL;
   procedure dbwinexit; cdecl; external DBLIBDLL;
   {$ENDIF}
   {$IFDEF freetds}
-  function tdsdbopen(login:PLOGINREC; servername:PChar; msdblib:INT):PDBPROCESS; cdecl; external DBLIBDLL;
+  function tdsdbopen(login:PLOGINREC; servername:PAnsiChar; msdblib:INT):PDBPROCESS; cdecl; external DBLIBDLL;
   function dbtablecolinfo(dbproc:PDBPROCESS; column:DBINT; dbcol:PDBCOL):RETCODE; cdecl; external DBLIBDLL;
   function dbtds(dbproc:PDBPROCESS):INT; cdecl; external DBLIBDLL;
   function dbsetlversion(login:PLOGINREC; version:BYTE):RETCODE; cdecl; external DBLIBDLL;
-  function dbservcharset(dbproc:PDBPROCESS):PChar; cdecl; external DBLIBDLL;
+  function dbservcharset(dbproc:PDBPROCESS):PAnsiChar; cdecl; external DBLIBDLL;
   procedure dbclose(dbproc:PDBPROCESS); cdecl; external DBLIBDLL;
   {$ENDIF}
 {$ELSE}
   var
-  dbinit: function():{$IFDEF freetds}RETCODE{$ELSE}PChar{$ENDIF}; cdecl;
+  dbinit: function():{$IFDEF freetds}RETCODE{$ELSE}PAnsiChar{$ENDIF}; cdecl;
   dblogin: function():PLOGINREC; cdecl;
-  dbsetlname: function(login:PLOGINREC; value:PChar; which:INT):RETCODE; cdecl;
+  dbsetlname: function(login:PLOGINREC; value:PAnsiChar; which:INT):RETCODE; cdecl;
   dbsetlogintime: function(seconds:INT):RETCODE; cdecl;
   dbsettime: function(seconds:INT):RETCODE; cdecl;
   dberrhandle: function(handler:DBERRHANDLE_PROC):DBERRHANDLE_PROC; cdecl;
   dbmsghandle: function(handler:DBMSGHANDLE_PROC):DBMSGHANDLE_PROC; cdecl;
-  dbsetopt: function(dbproc:PDBPROCESS; option: INT; param:PChar {$IFDEF freetds};int_param:INT{$ENDIF}):RETCODE; cdecl;
-  dbuse: function(dbproc:PDBPROCESS; dbname:PChar):RETCODE; cdecl;
-  dbcmd: function(dbproc:PDBPROCESS; cmdstring:PChar):RETCODE; cdecl;
+  dbsetopt: function(dbproc:PDBPROCESS; option: INT; param:PAnsiChar {$IFDEF freetds};int_param:INT{$ENDIF}):RETCODE; cdecl;
+  dbuse: function(dbproc:PDBPROCESS; dbname:PAnsiChar):RETCODE; cdecl;
+  dbcmd: function(dbproc:PDBPROCESS; cmdstring:PAnsiChar):RETCODE; cdecl;
   dbcmdrow: function(dbproc:PDBPROCESS):RETCODE; cdecl;
   dbsqlexec: function(dbproc:PDBPROCESS):RETCODE; cdecl;
   dbresults: function(dbproc:PDBPROCESS):RETCODE; cdecl;
   dbmorecmds: function(dbproc:PDBPROCESS):RETCODE; cdecl;
   dbnextrow: function(dbproc:PDBPROCESS):STATUS; cdecl;
   dbnumcols: function(dbproc:PDBPROCESS):INT; cdecl;
-  dbcolname: function(dbproc:PDBPROCESS; column:INT):PChar; cdecl;
+  dbcolname: function(dbproc:PDBPROCESS; column:INT):PAnsiChar; cdecl;
   dbcoltype: function(dbproc:PDBPROCESS; column:INT):INT; cdecl;
   dbcollen: function(dbproc:PDBPROCESS; column:INT):DBINT; cdecl;
   dbcolinfo: function(dbproc:PDBPROCESS; typ:INT; column:DBINT; computeid:DBINT; dbcol:PDBCOL):RETCODE; cdecl;
-  dbprtype: function(token:INT):PChar; cdecl;
+  dbprtype: function(token:INT):PAnsiChar; cdecl;
   dbdatlen: function(dbproc:PDBPROCESS; column:INT):DBINT; cdecl;
   dbdata: function(dbproc:PDBPROCESS; column:INT):PByte; cdecl;
   dbwillconvert: function(srctype, desttype: INT):{$IFDEF freetds}DBBOOL{$ELSE}BOOL{$ENDIF}; cdecl;
@@ -389,16 +390,16 @@ var
   dbexit: procedure(); cdecl;
   dbfreelogin: procedure(login:PLOGINREC); cdecl;
   {$IFDEF ntwdblib}
-  dbopen: function(login:PLOGINREC; servername:PChar):PDBPROCESS; cdecl;
+  dbopen: function(login:PLOGINREC; servername:PAnsiChar):PDBPROCESS; cdecl;
   dbclose: function(dbproc:PDBPROCESS):RETCODE; cdecl;
   dbwinexit: procedure; cdecl;
   {$ENDIF}
   {$IFDEF freetds}
-  tdsdbopen: function(login:PLOGINREC; servername:PChar; msdblib:INT):PDBPROCESS; cdecl;
+  tdsdbopen: function(login:PLOGINREC; servername:PAnsiChar; msdblib:INT):PDBPROCESS; 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;
-  dbservcharset: function(dbproc:PDBPROCESS):PChar; cdecl;
+  dbservcharset: function(dbproc:PDBPROCESS):PAnsiChar; cdecl;
   dbclose: procedure(dbproc:PDBPROCESS); cdecl;
   {$ENDIF}
 
@@ -407,17 +408,17 @@ var
 {$ENDIF}
 
 {$IFDEF ntwdblib}
-function tdsdbopen(login:PLOGINREC; servername:PChar; msdblib:INT):PDBPROCESS;
+function tdsdbopen(login:PLOGINREC; servername:PAnsiChar; msdblib:INT):PDBPROCESS;
 function dbtablecolinfo(dbproc:PDBPROCESS; column:DBINT; dbcol:PDBCOL):RETCODE;
 function dbsetlversion(login:PLOGINREC; version:BYTE):RETCODE;
 function dbtds(dbproc:PDBPROCESS):INT;
-function dbversion():PChar;
+function dbversion():PAnsiChar;
 {$ENDIF}
 {$IFDEF freetds}
-function dbopen(login:PLOGINREC; servername:PChar):PDBPROCESS;
+function dbopen(login:PLOGINREC; servername:PAnsiChar):PDBPROCESS;
 procedure dbwinexit;
 {$ENDIF}
-function dbsetlcharset(login:PLOGINREC; charset:PChar):RETCODE;
+function dbsetlcharset(login:PLOGINREC; charset:PAnsiChar):RETCODE;
 function dbsetlsecure(login:PLOGINREC):RETCODE;
 function dbdatetimeallcrack(dta: PDBDATETIMEALL): TDateTime;
 function dbmoneytocurr(pdbmoney: PQWord): Currency;
@@ -534,12 +535,12 @@ end;
 
 //functions, which are not implemented by FreeTDS:
 {$IFDEF freetds}
-function dbopen(login:PLOGINREC; servername:PChar):PDBPROCESS;
+function dbopen(login:PLOGINREC; servername:PAnsiChar):PDBPROCESS;
 begin
   Result:=tdsdbopen(login, servername, 1{1=MSDBLIB or 0=SYBDBLIB});
 end;
 
-function dbsetlcharset(login:PLOGINREC; charset:PChar):RETCODE;
+function dbsetlcharset(login:PLOGINREC; charset:PAnsiChar):RETCODE;
 begin
   Result:=dbsetlname(login, charset, 10);
 end;
@@ -558,7 +559,7 @@ end;
 
 //functions which are not implemented by ntwdblib:
 {$IFDEF ntwdblib}
-function tdsdbopen(login:PLOGINREC; servername:PChar; msdblib:INT):PDBPROCESS;
+function tdsdbopen(login:PLOGINREC; servername:PAnsiChar; msdblib:INT):PDBPROCESS;
 begin
   Result:=dbopen(login, servername);
 end;
@@ -578,7 +579,7 @@ begin
   Result:=dbsetlname(login, nil, version);
 end;
 
-function dbsetlcharset(login:PLOGINREC; charset:PChar):RETCODE;
+function dbsetlcharset(login:PLOGINREC; charset:PAnsiChar):RETCODE;
 begin
   Result:=SUCCEED;
 end;
@@ -593,7 +594,7 @@ begin
   Result:=0;
 end;
 
-function dbversion():PChar;
+function dbversion():PAnsiChar;
 begin
   Result:='DB Library version 8.00';
 end;

packages/fastcgi/fpmake.pp

@@ -24,7 +24,7 @@ begin
     P.Email := '';
     P.Description := 'FastCGI header translation to Pascal';
     P.NeedLibC:= false;
-    P.OSes := AllUnixOSes+AllWindowsOSes-[qnx]+[amiga,aros];
+    P.OSes := AllUnixOSes+AllWindowsOSes+AllAmigaLikeOSes-[qnx];
 
     P.SourcePath.Add('src');
 

packages/fcl-base/fpmake.pp

@@ -108,10 +108,15 @@ begin
     T:=P.Targets.AddUnit('fpexprpars.pp');
       T.ResourceStrings:=true;
 
-    // Windows units
     T:=P.Targets.AddUnit('fileinfo.pp');
     T:=P.Targets.addUnit('fpmimetypes.pp');
-
+    T:=P.Targets.AddUnit('csvreadwrite.pp');
+    T:=P.Targets.addUnit('csvdocument.pp');
+    With T.Dependencies do
+      begin
+      AddUnit('csvreadwrite');
+      AddUnit('contnrs');
+      end;
     // Additional sources
     P.Sources.AddSrcFiles('src/win/fclel.*');
     // Install windows resources

packages/fcl-base/src/avl_tree.pp

@@ -77,7 +77,7 @@ type
     Root: TAVLTreeNode;
     function Find(Data: Pointer): TAVLTreeNode;
     function FindKey(Key: Pointer;
-      OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+      const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
     function FindSuccessor(ANode: TAVLTreeNode): TAVLTreeNode;
     function FindPrecessor(ANode: TAVLTreeNode): TAVLTreeNode;
     function FindLowest: TAVLTreeNode;
@@ -87,9 +87,9 @@ type
     function FindLeftMost(Data: Pointer): TAVLTreeNode;
     function FindRightMost(Data: Pointer): TAVLTreeNode;
     function FindLeftMostKey(Key: Pointer;
-      OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+      const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
     function FindRightMostKey(Key: Pointer;
-      OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+      const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
     function FindLeftMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
     function FindRightMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
     procedure Add(ANode: TAVLTreeNode);
@@ -109,7 +109,7 @@ type
     function ReportAsString: string;
     procedure SetNodeManager(NewMgr: TBaseAVLTreeNodeManager;
                              AutoFree: boolean = false);
-    constructor Create(OnCompareMethod: TListSortCompare);
+    constructor Create(const OnCompareMethod: TListSortCompare);
     constructor Create;
     destructor Destroy; override;
     function GetEnumerator: TAVLTreeNodeEnumerator;
@@ -520,7 +520,7 @@ begin
   FCount:=0;
 end;
 
-constructor TAVLTree.Create(OnCompareMethod: TListSortCompare);
+constructor TAVLTree.Create(const OnCompareMethod: TListSortCompare);
 begin
   inherited Create;
   fNodeMgr:=NodeMemManager;
@@ -700,7 +700,7 @@ begin
   end;
 end;
 
-function TAVLTree.FindKey(Key: Pointer; OnCompareKeyWithData: TListSortCompare
+function TAVLTree.FindKey(Key: Pointer; const OnCompareKeyWithData: TListSortCompare
   ): TAVLTreeNode;
 var Comp: integer;
 begin
@@ -717,15 +717,31 @@ begin
 end;
 
 function TAVLTree.FindLeftMostKey(Key: Pointer;
-  OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+  const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+var
+  LeftNode: TAVLTreeNode;
 begin
-  Result:=FindLeftMostSameKey(FindKey(Key,OnCompareKeyWithData));
+  Result:=FindKey(Key,OnCompareKeyWithData);
+  if Result=nil then exit;
+  repeat
+    LeftNode:=FindPrecessor(Result);
+    if (LeftNode=nil) or (OnCompareKeyWithData(Key,LeftNode.Data)<>0) then exit;
+    Result:=LeftNode;
+  until false;
 end;
 
 function TAVLTree.FindRightMostKey(Key: Pointer;
-  OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+  const OnCompareKeyWithData: TListSortCompare): TAVLTreeNode;
+var
+  RightNode: TAVLTreeNode;
 begin
-  Result:=FindRightMostSameKey(FindKey(Key,OnCompareKeyWithData));
+  Result:=FindKey(Key,OnCompareKeyWithData);
+  if Result=nil then exit;
+  repeat
+    RightNode:=FindSuccessor(Result);
+    if (RightNode=nil) or (OnCompareKeyWithData(Key,RightNode.Data)<>0) then exit;
+    Result:=RightNode;
+  until false;
 end;
 
 function TAVLTree.FindLeftMostSameKey(ANode: TAVLTreeNode): TAVLTreeNode;
@@ -738,7 +754,7 @@ begin
     Result:=ANode;
     repeat
       LeftNode:=FindPrecessor(Result);
-      if (LeftNode=nil) or (fOnCompare(Data,LeftNode.Data)<>0) then break;
+      if (LeftNode=nil) or (FOnCompare(Data,LeftNode.Data)<>0) then break;
       Result:=LeftNode;
     until false;
   end else begin
@@ -756,7 +772,7 @@ begin
     Result:=ANode;
     repeat
       RightNode:=FindSuccessor(Result);
-      if (RightNode=nil) or (fOnCompare(Data,RightNode.Data)<>0) then break;
+      if (RightNode=nil) or (FOnCompare(Data,RightNode.Data)<>0) then break;
       Result:=RightNode;
     until false;
   end else begin

packages/fcl-base/src/contnrs.pp

@@ -360,7 +360,6 @@ type
   TFPCustomHashTable = class(TObject)
   private
     FHashTable: TFPObjectList;
-    FHashTableSize: Longword;
     FHashFunction: THashFunction;
     FCount: Longword;
     Function GetDensity: Longword;
@@ -372,6 +371,7 @@ type
     Function GetAVGChainLen: double;
     Function GetMaxChainLength: Longword;
   protected
+    FHashTableSize: Longword;
     Function Chain(const index: Longword):TFPObjectList;
     Function CreateNewNode(const aKey : string) : THTCustomNode; virtual; abstract;
     Procedure AddNode(ANode : THTCustomNode); virtual; abstract;

packages/fcl-base/src/csvdocument.pp

@@ -0,0 +1,586 @@
+{
+  CSV  Document classes.
+  Version 0.5 2014-10-25
+
+  Copyright (C) 2010-2014 Vladimir Zhirov <[email protected]>
+
+  Contributors:
+    Luiz Americo Pereira Camara
+    Mattias Gaertner
+    Reinier Olislagers
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version with the following modification:
+
+  As a special exception, the copyright holders of this library give you
+  permission to link this library with independent modules to produce an
+  executable, regardless of the license terms of these independent modules,and
+  to copy and distribute the resulting executable under terms of your choice,
+  provided that you also meet, for each linked independent module, the terms
+  and conditions of the license of that module. An independent module is a
+  module which is not derived from or based on this library. If you modify
+  this library, you may extend this exception to your version of the library,
+  but you are not obligated to do so. If you do not wish to do so, delete this
+  exception statement from your version.
+
+  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. See the GNU Library General Public License
+  for more details.
+
+  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.
+}
+
+unit csvdocument;
+
+{$IFDEF FPC}
+  {$MODE DELPHI}
+{$ENDIF}
+
+interface
+
+uses
+  Classes, SysUtils, Contnrs, csvreadwrite;
+
+type
+  TCSVChar = csvreadwrite.TCSVChar;
+  TCSVParser = csvreadwrite.TCSVParser;
+  TCSVBuilder = csvreadwrite.TCSVBuilder;
+
+  {$IFNDEF FPC}
+  TFPObjectList = TObjectList;
+  {$ENDIF}
+
+  // Random access to CSV document. Reads entire document into memory.
+  TCSVDocument = class(TCSVHandler)
+  private
+    FRows: TFPObjectList;
+    FParser: TCSVParser;
+    FBuilder: TCSVBuilder;
+    // helpers
+    procedure ForceRowIndex(ARowIndex: Integer);
+    function  CreateNewRow(const AFirstCell: String = ''): TObject;
+    // property getters/setters
+    function  GetCell(ACol, ARow: Integer): String;
+    procedure SetCell(ACol, ARow: Integer; const AValue: String);
+    function  GetCSVText: String;
+    procedure SetCSVText(const AValue: String);
+    function  GetRowCount: Integer;
+    function  GetColCount(ARow: Integer): Integer;
+    function  GetMaxColCount: Integer;
+  public
+    constructor Create;
+    destructor  Destroy; override;
+
+    // Input/output
+
+    // Load document from file AFileName
+    procedure LoadFromFile(const AFilename: String);
+    // Load document from stream AStream
+    procedure LoadFromStream(AStream: TStream);
+    // Save document to file AFilename
+    procedure SaveToFile(const AFilename: String);
+    // Save document to stream AStream
+    procedure SaveToStream(AStream: TStream);
+
+    // Row and cell operations
+
+    // Add a new row and a cell with content AFirstCell
+    procedure AddRow(const AFirstCell: String = '');
+    // Add a cell at row ARow with data AValue
+    procedure AddCell(ARow: Integer; const AValue: String = '');
+    // Insert a row at row ARow with first cell data AFirstCell
+    // If there is no row ARow, insert row at end
+    procedure InsertRow(ARow: Integer; const AFirstCell: String = '');
+    // Insert a cell at specified position with data AValue
+    procedure InsertCell(ACol, ARow: Integer; const AValue: String = '');
+    // Remove specified row
+    procedure RemoveRow(ARow: Integer);
+    // Remove specified cell
+    procedure RemoveCell(ACol, ARow: Integer);
+    // Indicates if there is a row at specified position
+    function  HasRow(ARow: Integer): Boolean;
+    // Indicates if there is a cell at specified position
+    function  HasCell(ACol, ARow: Integer): Boolean;
+    
+    // Search
+    
+    // Return column for cell data AString at row ARow
+    function  IndexOfCol(const AString: String; ARow: Integer): Integer;
+    // Return row for cell data AString at coloumn ACol
+    function  IndexOfRow(const AString: String; ACol: Integer): Integer;
+
+    // Utils
+
+    // Remove all data
+    procedure Clear;
+    // Copy entire row ARow to row position AInsertPos.
+    // Adds empty rows if necessary
+    procedure CloneRow(ARow, AInsertPos: Integer);
+    // Exchange contents of the two specified rows
+    procedure ExchangeRows(ARow1, ARow2: Integer);
+    // Rewrite all line endings within cell data to LineEnding
+    procedure UnifyEmbeddedLineEndings;
+    // Remove empty cells at end of rows from entire document
+    procedure RemoveTrailingEmptyCells;
+
+    // Properties
+
+    // Cell data at column ACol, row ARow.
+    property Cells[ACol, ARow: Integer]: String read GetCell write SetCell; default;
+    // Number of rows
+    property RowCount: Integer read GetRowCount;
+    // Number of columns for row ARow
+    property ColCount[ARow: Integer]: Integer read GetColCount;
+    // Maximum number of columns found in all rows in document
+    property MaxColCount: Integer read GetMaxColCount;
+    // Document formatted as CSV text
+    property CSVText: String read GetCSVText write SetCSVText;
+  end;
+
+implementation
+
+
+//------------------------------------------------------------------------------
+
+type
+  TCSVCell = class
+  public
+    // Value (contents) of cell in string form
+    Value: String;
+  end;
+
+  TCSVRow = class
+  private
+    FCells: TFPObjectList;
+    procedure ForceCellIndex(ACellIndex: Integer);
+    function  CreateNewCell(const AValue: String): TCSVCell;
+    function  GetCellValue(ACol: Integer): String;
+    procedure SetCellValue(ACol: Integer; const AValue: String);
+    function  GetColCount: Integer;
+  public
+    constructor Create;
+    destructor  Destroy; override;
+    // cell operations
+    // Add cell with value AValue to row
+    procedure AddCell(const AValue: String = '');
+    // Insert cell with value AValue at specified column
+    procedure InsertCell(ACol: Integer; const AValue: String);
+    // Remove cell from specified column
+    procedure RemoveCell(ACol: Integer);
+    // Indicates if specified column contains a cell/data
+    function  HasCell(ACol: Integer): Boolean;
+    // utilities
+    // Copy entire row
+    function  Clone: TCSVRow;
+    // Remove all empty cells at the end of the row
+    procedure TrimEmptyCells;
+    // Replace various line endings in data with ALineEnding
+    procedure SetValuesLineEnding(const ALineEnding: String);
+    // properties
+    // Value/data of cell at column ACol
+    property CellValue[ACol: Integer]: String read GetCellValue write SetCellValue;
+    // Number of columns in row
+    property ColCount: Integer read GetColCount;
+  end;
+
+{ TCSVRow }
+
+procedure TCSVRow.ForceCellIndex(ACellIndex: Integer);
+begin
+  while FCells.Count <= ACellIndex do
+    AddCell();
+end;
+
+function TCSVRow.CreateNewCell(const AValue: String): TCSVCell;
+begin
+  Result := TCSVCell.Create;
+  Result.Value := AValue;
+end;
+
+function TCSVRow.GetCellValue(ACol: Integer): String;
+begin
+  if HasCell(ACol) then
+    Result := TCSVCell(FCells[ACol]).Value
+  else
+    Result := '';
+end;
+
+procedure TCSVRow.SetCellValue(ACol: Integer; const AValue: String);
+begin
+  ForceCellIndex(ACol);
+  TCSVCell(FCells[ACol]).Value := AValue;
+end;
+
+function TCSVRow.GetColCount: Integer;
+begin
+  Result := FCells.Count;
+end;
+
+constructor TCSVRow.Create;
+begin
+  inherited Create;
+  FCells := TFPObjectList.Create;
+end;
+
+destructor TCSVRow.Destroy;
+begin
+  FreeAndNil(FCells);
+  inherited Destroy;
+end;
+
+procedure TCSVRow.AddCell(const AValue: String = '');
+begin
+  FCells.Add(CreateNewCell(AValue));
+end;
+
+procedure TCSVRow.InsertCell(ACol: Integer; const AValue: String);
+begin
+  FCells.Insert(ACol, CreateNewCell(AValue));
+end;
+
+procedure TCSVRow.RemoveCell(ACol: Integer);
+begin
+  if HasCell(ACol) then
+    FCells.Delete(ACol);
+end;
+
+function TCSVRow.HasCell(ACol: Integer): Boolean;
+begin
+  Result := (ACol >= 0) and (ACol < FCells.Count);
+end;
+
+function TCSVRow.Clone: TCSVRow;
+var
+  I: Integer;
+begin
+  Result := TCSVRow.Create;
+  for I := 0 to ColCount - 1 do
+    Result.AddCell(CellValue[I]);
+end;
+
+procedure TCSVRow.TrimEmptyCells;
+var
+  I: Integer;
+  MaxCol: Integer;
+begin
+  MaxCol := FCells.Count - 1;
+  for I := MaxCol downto 0 do
+  begin
+    if (TCSVCell(FCells[I]).Value = '') then
+    begin
+      if (FCells.Count > 1) then
+        FCells.Delete(I);
+    end else
+      break; // We hit the first non-empty cell so stop
+  end;
+end;
+
+procedure TCSVRow.SetValuesLineEnding(const ALineEnding: String);
+var
+  I: Integer;
+begin
+  for I := 0 to FCells.Count - 1 do
+    CellValue[I] := ChangeLineEndings(CellValue[I], ALineEnding);
+end;
+
+{ TCSVDocument }
+
+procedure TCSVDocument.ForceRowIndex(ARowIndex: Integer);
+begin
+  while FRows.Count <= ARowIndex do
+    AddRow();
+end;
+
+function TCSVDocument.CreateNewRow(const AFirstCell: String): TObject;
+var
+  NewRow: TCSVRow;
+begin
+  NewRow := TCSVRow.Create;
+  if AFirstCell <> '' then
+    NewRow.AddCell(AFirstCell);
+  Result := NewRow;
+end;
+
+function TCSVDocument.GetCell(ACol, ARow: Integer): String;
+begin
+  if HasRow(ARow) then
+    Result := TCSVRow(FRows[ARow]).CellValue[ACol]
+  else
+    Result := '';
+end;
+
+procedure TCSVDocument.SetCell(ACol, ARow: Integer; const AValue: String);
+begin
+  ForceRowIndex(ARow);
+  TCSVRow(FRows[ARow]).CellValue[ACol] := AValue;
+end;
+
+function TCSVDocument.GetCSVText: String;
+var
+  StringStream: TStringStream;
+begin
+  StringStream := TStringStream.Create('');
+  try
+    SaveToStream(StringStream);
+    Result := StringStream.DataString;
+  finally
+    FreeAndNil(StringStream);
+  end;
+end;
+
+procedure TCSVDocument.SetCSVText(const AValue: String);
+var
+  StringStream: TStringStream;
+begin
+  StringStream := TStringStream.Create(AValue);
+  try
+    LoadFromStream(StringStream);
+  finally
+    FreeAndNil(StringStream);
+  end;
+end;
+
+function TCSVDocument.GetRowCount: Integer;
+begin
+  Result := FRows.Count;
+end;
+
+function TCSVDocument.GetColCount(ARow: Integer): Integer;
+begin
+  if HasRow(ARow) then
+    Result := TCSVRow(FRows[ARow]).ColCount
+  else
+    Result := 0;
+end;
+
+// Returns maximum number of columns in the document
+function TCSVDocument.GetMaxColCount: Integer;
+var
+  I, CC: Integer;
+begin
+  // While calling MaxColCount in TCSVParser could work,
+  // we'd need to adjust for any subsequent changes in
+  // TCSVDocument
+  Result := 0;
+  for I := 0 to RowCount - 1 do
+  begin
+    CC := ColCount[I];
+    if CC > Result then
+      Result := CC;
+  end;
+end;
+
+constructor TCSVDocument.Create;
+begin
+  inherited Create;
+  FRows := TFPObjectList.Create;
+  FParser := nil;
+  FBuilder := nil;
+end;
+
+destructor TCSVDocument.Destroy;
+begin
+  FreeAndNil(FBuilder);
+  FreeAndNil(FParser);
+  FreeAndNil(FRows);
+  inherited Destroy;
+end;
+
+procedure TCSVDocument.LoadFromFile(const AFilename: String);
+var
+  FileStream: TFileStream;
+begin
+  FileStream := TFileStream.Create(AFilename, fmOpenRead or fmShareDenyNone);
+  try
+    LoadFromStream(FileStream);
+  finally
+    FileStream.Free;
+  end;
+end;
+
+procedure TCSVDocument.LoadFromStream(AStream: TStream);
+var
+  I, J, MaxCol: Integer;
+begin
+  Clear;
+
+  if not Assigned(FParser) then
+    FParser := TCSVParser.Create;
+
+  FParser.AssignCSVProperties(Self);
+  with FParser do
+  begin
+    SetSource(AStream);
+    while ParseNextCell do
+      Cells[CurrentCol, CurrentRow] := CurrentCellText;
+  end;
+
+  if FEqualColCountPerRow then
+  begin
+    MaxCol := MaxColCount - 1;
+    for I := 0 to RowCount - 1 do
+      for J := ColCount[I] to MaxCol do
+        Cells[J, I] := '';
+  end;
+end;
+
+procedure TCSVDocument.SaveToFile(const AFilename: String);
+var
+  FileStream: TFileStream;
+begin
+  FileStream := TFileStream.Create(AFilename, fmCreate);
+  try
+    SaveToStream(FileStream);
+  finally
+    FileStream.Free;
+  end;
+end;
+
+procedure TCSVDocument.SaveToStream(AStream: TStream);
+var
+  I, J, MaxCol: Integer;
+begin
+  if not Assigned(FBuilder) then
+    FBuilder := TCSVBuilder.Create;
+
+  FBuilder.AssignCSVProperties(Self);
+  with FBuilder do
+  begin
+    if FEqualColCountPerRow then
+      MaxCol := MaxColCount - 1;
+
+    SetOutput(AStream);
+    for I := 0 to RowCount - 1 do
+    begin
+      if not FEqualColCountPerRow then
+        MaxCol := ColCount[I] - 1;
+      for J := 0 to MaxCol do
+        AppendCell(Cells[J, I]);
+      AppendRow;
+    end;
+  end;
+end;
+
+procedure TCSVDocument.AddRow(const AFirstCell: String = '');
+begin
+  FRows.Add(CreateNewRow(AFirstCell));
+end;
+
+procedure TCSVDocument.AddCell(ARow: Integer; const AValue: String = '');
+begin
+  ForceRowIndex(ARow);
+  TCSVRow(FRows[ARow]).AddCell(AValue);
+end;
+
+procedure TCSVDocument.InsertRow(ARow: Integer; const AFirstCell: String = '');
+begin
+  if HasRow(ARow) then
+    FRows.Insert(ARow, CreateNewRow(AFirstCell))
+  else
+    AddRow(AFirstCell);
+end;
+
+procedure TCSVDocument.InsertCell(ACol, ARow: Integer; const AValue: String);
+begin
+  ForceRowIndex(ARow);
+  TCSVRow(FRows[ARow]).InsertCell(ACol, AValue);
+end;
+
+procedure TCSVDocument.RemoveRow(ARow: Integer);
+begin
+  if HasRow(ARow) then
+    FRows.Delete(ARow);
+end;
+
+procedure TCSVDocument.RemoveCell(ACol, ARow: Integer);
+begin
+  if HasRow(ARow) then
+    TCSVRow(FRows[ARow]).RemoveCell(ACol);
+end;
+
+function TCSVDocument.HasRow(ARow: Integer): Boolean;
+begin
+  Result := (ARow >= 0) and (ARow < FRows.Count);
+end;
+
+function TCSVDocument.HasCell(ACol, ARow: Integer): Boolean;
+begin
+  if HasRow(ARow) then
+    Result := TCSVRow(FRows[ARow]).HasCell(ACol)
+  else
+    Result := False;
+end;
+
+function TCSVDocument.IndexOfCol(const AString: String; ARow: Integer): Integer;
+var
+  CC: Integer;
+begin
+  CC := ColCount[ARow];
+  Result := 0;
+  while (Result < CC) and (Cells[Result, ARow] <> AString) do
+    Inc(Result);
+  if Result = CC then
+    Result := -1;
+end;
+
+function TCSVDocument.IndexOfRow(const AString: String; ACol: Integer): Integer;
+var
+  RC: Integer;
+begin
+  RC := RowCount;
+  Result := 0;
+  while (Result < RC) and (Cells[ACol, Result] <> AString) do
+    Inc(Result);
+  if Result = RC then
+    Result := -1;
+end;
+
+procedure TCSVDocument.Clear;
+begin
+  FRows.Clear;
+end;
+
+procedure TCSVDocument.CloneRow(ARow, AInsertPos: Integer);
+var
+  NewRow: TObject;
+begin
+  if not HasRow(ARow) then
+    Exit;
+  NewRow := TCSVRow(FRows[ARow]).Clone;
+  if not HasRow(AInsertPos) then
+  begin
+    ForceRowIndex(AInsertPos - 1);
+    FRows.Add(NewRow);
+  end else
+    FRows.Insert(AInsertPos, NewRow);
+end;
+
+procedure TCSVDocument.ExchangeRows(ARow1, ARow2: Integer);
+begin
+  if not (HasRow(ARow1) and HasRow(ARow2)) then
+    Exit;
+  FRows.Exchange(ARow1, ARow2);
+end;
+
+procedure TCSVDocument.UnifyEmbeddedLineEndings;
+var
+  I: Integer;
+begin
+  for I := 0 to FRows.Count - 1 do
+    TCSVRow(FRows[I]).SetValuesLineEnding(FLineEnding);
+end;
+
+procedure TCSVDocument.RemoveTrailingEmptyCells;
+var
+  I: Integer;
+begin
+  for I := 0 to FRows.Count - 1 do
+    TCSVRow(FRows[I]).TrimEmptyCells;
+end;
+
+end.

packages/fcl-base/src/csvreadwrite.pp

@@ -0,0 +1,599 @@
+{
+  CSV Parser, Builder classes.
+  Version 0.5 2014-10-25
+
+  Copyright (C) 2010-2014 Vladimir Zhirov <[email protected]>
+
+  Contributors:
+    Luiz Americo Pereira Camara
+    Mattias Gaertner
+    Reinier Olislagers
+
+  This library is free software; you can redistribute it and/or modify it
+  under the terms of the GNU Library General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or (at your
+  option) any later version with the following modification:
+
+  As a special exception, the copyright holders of this library give you
+  permission to link this library with independent modules to produce an
+  executable, regardless of the license terms of these independent modules,and
+  to copy and distribute the resulting executable under terms of your choice,
+  provided that you also meet, for each linked independent module, the terms
+  and conditions of the license of that module. An independent module is a
+  module which is not derived from or based on this library. If you modify
+  this library, you may extend this exception to your version of the library,
+  but you are not obligated to do so. If you do not wish to do so, delete this
+  exception statement from your version.
+
+  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. See the GNU Library General Public License
+  for more details.
+
+  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.
+}
+
+unit csvreadwrite;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, strutils;
+
+Type
+  TCSVChar = Char;
+
+  { TCSVHandler }
+
+  TCSVHandler = class(TPersistent)
+  private
+    procedure SetDelimiter(const AValue: TCSVChar);
+    procedure SetQuoteChar(const AValue: TCSVChar);
+    procedure UpdateCachedChars;
+  protected
+    // special chars
+    FDelimiter: TCSVChar;
+    FQuoteChar: TCSVChar;
+    FLineEnding: String;
+    // cached values to speed up special chars operations
+    FSpecialChars: TSysCharSet;
+    FDoubleQuote: String;
+    // parser settings
+    FIgnoreOuterWhitespace: Boolean;
+    // builder settings
+    FQuoteOuterWhitespace: Boolean;
+    // document settings
+    FEqualColCountPerRow: Boolean;
+  public
+    constructor Create; virtual;
+    procedure Assign(ASource: TPersistent); override;
+    procedure AssignCSVProperties(ASource: TCSVHandler);
+    // Delimiter that separates the field, e.g. comma, semicolon, tab
+    property Delimiter: TCSVChar read FDelimiter write SetDelimiter;
+    // Character used to quote "problematic" data
+    // (e.g. with delimiters or spaces in them)
+    // A common quotechar is "
+    property QuoteChar: TCSVChar read FQuoteChar write SetQuoteChar;
+    // String at the end of the line of data (e.g. CRLF)
+    property LineEnding: String read FLineEnding write FLineEnding;
+    // Ignore whitespace between delimiters and field data
+    property IgnoreOuterWhitespace: Boolean read FIgnoreOuterWhitespace write FIgnoreOuterWhitespace;
+    // Use quotes when outer whitespace is found
+    property QuoteOuterWhitespace: Boolean read FQuoteOuterWhitespace write FQuoteOuterWhitespace;
+    // When reading and writing: make sure every line has the same column count, create empty cells in the end of row if required
+    property EqualColCountPerRow: Boolean read FEqualColCountPerRow write FEqualColCountPerRow;
+  end;
+
+  // Sequential input from CSV stream
+
+  { TCSVParser }
+
+  TCSVParser = class(TCSVHandler)
+  private
+    FFreeStream: Boolean;
+    // fields
+    FSourceStream: TStream;
+    FStrStreamWrapper: TStringStream;
+    // parser state
+    EndOfFile: Boolean;
+    EndOfLine: Boolean;
+    FCurrentChar: TCSVChar;
+    FCurrentRow: Integer;
+    FCurrentCol: Integer;
+    FMaxColCount: Integer;
+    // output buffers
+    FCellBuffer: String;
+    FWhitespaceBuffer: String;
+    procedure ClearOutput;
+    // basic parsing
+    procedure SkipEndOfLine;
+    procedure SkipDelimiter;
+    procedure SkipWhitespace;
+    procedure NextChar;
+    // complex parsing
+    procedure ParseCell;
+    procedure ParseQuotedValue;
+    // simple parsing
+    procedure ParseValue;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    // Source data stream
+    procedure SetSource(AStream: TStream); overload;
+    // Source data string.
+    procedure SetSource(const AString: String); overload;
+    // Rewind to beginning of data
+    procedure ResetParser;
+    // Read next cell data; return false if end of file reached
+    function  ParseNextCell: Boolean;
+    // Current row (0 based)
+    property CurrentRow: Integer read FCurrentRow;
+    // Current column (0 based); -1 if invalid/before beginning of file
+    property CurrentCol: Integer read FCurrentCol;
+    // Data in current cell
+    property CurrentCellText: String read FCellBuffer;
+    // The maximum number of columns found in the stream:
+    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;
+  end;
+
+  // Sequential output to CSV stream
+  TCSVBuilder = class(TCSVHandler)
+  private
+    FOutputStream: TStream;
+    FDefaultOutput: TMemoryStream;
+    FNeedLeadingDelimiter: Boolean;
+    function GetDefaultOutputAsString: String;
+  protected
+    procedure AppendStringToStream(const AString: String; AStream: TStream);
+    function  QuoteCSVString(const AValue: String): String;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    // Set output/destination stream.
+    // If not called, output is sent to DefaultOutput
+    procedure SetOutput(AStream: TStream);
+    // If using default stream, reset output to beginning.
+    // If using user-defined stream, user should reposition stream himself
+    procedure ResetBuilder;
+    // Add a cell to the output with data AValue
+    procedure AppendCell(const AValue: String);
+    // Write end of row to the output, starting a new row
+    procedure AppendRow;
+    // Default output as memorystream (if output not set using SetOutput)
+    property DefaultOutput: TMemoryStream read FDefaultOutput;
+    // Default output in string format (if output not set using SetOutput)
+    property DefaultOutputAsString: String read GetDefaultOutputAsString;
+  end;
+
+function ChangeLineEndings(const AString, ALineEnding: String): String;
+
+implementation
+
+const
+  CsvCharSize = SizeOf(TCSVChar);
+  CR    = #13;
+  LF    = #10;
+  HTAB  = #9;
+  SPACE = #32;
+  WhitespaceChars = [HTAB, SPACE];
+  LineEndingChars = [CR, LF];
+
+// The following implementation of ChangeLineEndings function originates from
+// Lazarus CodeTools library by Mattias Gaertner. It was explicitly allowed
+// by Mattias to relicense it under modified LGPL and include into CsvDocument.
+
+function ChangeLineEndings(const AString, ALineEnding: String): String;
+var
+  I: Integer;
+  Src: PChar;
+  Dest: PChar;
+  DestLength: Integer;
+  EndingLength: Integer;
+  EndPos: PChar;
+begin
+  if AString = '' then
+    Exit(AString);
+  EndingLength := Length(ALineEnding);
+  DestLength := Length(AString);
+
+  Src := PChar(AString);
+  EndPos := Src + DestLength;
+  while Src < EndPos do
+  begin
+    if (Src^ = CR) then
+    begin
+      Inc(Src);
+      if (Src^ = LF) then
+      begin
+        Inc(Src);
+        Inc(DestLength, EndingLength - 2);
+      end else
+        Inc(DestLength, EndingLength - 1);
+    end else
+    begin
+      if (Src^ = LF) then
+        Inc(DestLength, EndingLength - 1);
+      Inc(Src);
+    end;
+  end;
+
+  SetLength(Result, DestLength);
+  Src := PChar(AString);
+  Dest := PChar(Result);
+  EndPos := Dest + DestLength;
+  while (Dest < EndPos) do
+  begin
+    if Src^ in LineEndingChars then
+    begin
+      for I := 1 to EndingLength do
+      begin
+        Dest^ := ALineEnding[I];
+        Inc(Dest);
+      end;
+      if (Src^ = CR) and (Src[1] = LF) then
+        Inc(Src, 2)
+      else
+        Inc(Src);
+    end else
+    begin
+      Dest^ := Src^;
+      Inc(Src);
+      Inc(Dest);
+    end;
+  end;
+end;
+
+{ TCSVHandler }
+
+procedure TCSVHandler.SetDelimiter(const AValue: TCSVChar);
+begin
+  if FDelimiter <> AValue then
+  begin
+    FDelimiter := AValue;
+    UpdateCachedChars;
+  end;
+end;
+
+procedure TCSVHandler.SetQuoteChar(const AValue: TCSVChar);
+begin
+  if FQuoteChar <> AValue then
+  begin
+    FQuoteChar := AValue;
+    UpdateCachedChars;
+  end;
+end;
+
+procedure TCSVHandler.UpdateCachedChars;
+begin
+  FDoubleQuote := FQuoteChar + FQuoteChar;
+  FSpecialChars := [CR, LF, FDelimiter, FQuoteChar];
+end;
+
+constructor TCSVHandler.Create;
+begin
+  inherited Create;
+  FDelimiter := ',';
+  FQuoteChar := '"';
+  FLineEnding := sLineBreak;
+  FIgnoreOuterWhitespace := False;
+  FQuoteOuterWhitespace := True;
+  FEqualColCountPerRow := True;
+  UpdateCachedChars;
+end;
+
+procedure TCSVHandler.Assign(ASource: TPersistent);
+begin
+  if (ASource is TCSVHandler) then
+    AssignCSVProperties(ASource as TCSVHandler)
+  else
+    inherited Assign(ASource);
+end;
+
+procedure TCSVHandler.AssignCSVProperties(ASource: TCSVHandler);
+begin
+  FDelimiter := ASource.FDelimiter;
+  FQuoteChar := ASource.FQuoteChar;
+  FLineEnding := ASource.FLineEnding;
+  FIgnoreOuterWhitespace := ASource.FIgnoreOuterWhitespace;
+  FQuoteOuterWhitespace := ASource.FQuoteOuterWhitespace;
+  FEqualColCountPerRow := ASource.FEqualColCountPerRow;
+  UpdateCachedChars;
+end;
+
+{ TCSVParser }
+
+procedure TCSVParser.ClearOutput;
+begin
+  FCellBuffer := '';
+  FWhitespaceBuffer := '';
+  FCurrentRow := 0;
+  FCurrentCol := -1;
+  FMaxColCount := 0;
+end;
+
+procedure TCSVParser.SkipEndOfLine;
+begin
+  // treat LF+CR as two linebreaks, not one
+  if (FCurrentChar = CR) then
+    NextChar;
+  if (FCurrentChar = LF) then
+    NextChar;
+end;
+
+procedure TCSVParser.SkipDelimiter;
+begin
+  if FCurrentChar = FDelimiter then
+    NextChar;
+end;
+
+procedure TCSVParser.SkipWhitespace;
+begin
+  while FCurrentChar = SPACE do
+    NextChar;
+end;
+
+procedure TCSVParser.NextChar;
+begin
+  if FSourceStream.Read(FCurrentChar, CsvCharSize) < CsvCharSize then
+  begin
+    FCurrentChar := #0;
+    EndOfFile := True;
+  end;
+  EndOfLine := FCurrentChar in LineEndingChars;
+end;
+
+procedure TCSVParser.ParseCell;
+begin
+  FCellBuffer := '';
+  if FIgnoreOuterWhitespace then
+    SkipWhitespace;
+  if FCurrentChar = FQuoteChar then
+    ParseQuotedValue
+  else
+    ParseValue;
+end;
+
+procedure TCSVParser.ParseQuotedValue;
+var
+  QuotationEnd: Boolean;
+begin
+  NextChar; // skip opening quotation char
+  repeat
+    // read value up to next quotation char
+    while not ((FCurrentChar = FQuoteChar) or EndOfFile) do
+    begin
+      if EndOfLine then
+      begin
+        AppendStr(FCellBuffer, FLineEnding);
+        SkipEndOfLine;
+      end else
+      begin
+        AppendStr(FCellBuffer, FCurrentChar);
+        NextChar;
+      end;
+    end;
+    // skip quotation char (closing or escaping)
+    if not EndOfFile then
+      NextChar;
+    // check if it was escaping
+    if FCurrentChar = FQuoteChar then
+    begin
+      AppendStr(FCellBuffer, FCurrentChar);
+      QuotationEnd := False;
+      NextChar;
+    end else
+      QuotationEnd := True;
+  until QuotationEnd;
+  // read the rest of the value until separator or new line
+  ParseValue;
+end;
+
+procedure TCSVParser.ParseValue;
+begin
+  while not ((FCurrentChar = FDelimiter) or EndOfLine or EndOfFile) do
+  begin
+    AppendStr(FWhitespaceBuffer, FCurrentChar);
+    NextChar;
+  end;
+  // merge whitespace buffer
+  if FIgnoreOuterWhitespace then
+    RemoveTrailingChars(FWhitespaceBuffer, WhitespaceChars);
+  AppendStr(FCellBuffer, FWhitespaceBuffer);
+  FWhitespaceBuffer := '';
+end;
+
+constructor TCSVParser.Create;
+begin
+  inherited Create;
+  ClearOutput;
+  FStrStreamWrapper := nil;
+  EndOfFile := True;
+end;
+
+destructor TCSVParser.Destroy;
+begin
+  if FFreeStream and (FSourceStream<>FStrStreamWrapper) then
+     FreeAndNil(FSourceStream);
+  FreeAndNil(FStrStreamWrapper);
+  inherited Destroy;
+end;
+
+procedure TCSVParser.SetSource(AStream: TStream);
+begin
+  If FSourceStream=AStream then exit;
+  if FFreeStream and (FSourceStream<>FStrStreamWrapper) then
+     FreeAndNil(FSourceStream);
+  FSourceStream := AStream;
+  ResetParser;
+end;
+
+procedure TCSVParser.SetSource(const AString: String); overload;
+begin
+  FreeAndNil(FStrStreamWrapper);
+  FStrStreamWrapper := TStringStream.Create(AString);
+  SetSource(FStrStreamWrapper);
+end;
+
+procedure TCSVParser.ResetParser;
+begin
+  ClearOutput;
+  FSourceStream.Seek(0, soFromBeginning);
+  EndOfFile := False;
+  NextChar;
+end;
+
+// Parses next cell; returns True if there are more cells in the input stream.
+function TCSVParser.ParseNextCell: Boolean;
+var
+  LineColCount: Integer;
+begin
+  if EndOfLine or EndOfFile then
+  begin
+    // Having read the previous line, adjust column count if necessary:
+    LineColCount := FCurrentCol + 1;
+    if LineColCount > FMaxColCount then
+      FMaxColCount := LineColCount;
+  end;
+
+  if EndOfFile then
+    Exit(False);
+
+  // Handle line ending
+  if EndOfLine then
+  begin
+    SkipEndOfLine;
+    if EndOfFile then
+      Exit(False);
+    FCurrentCol := 0;
+    Inc(FCurrentRow);
+  end else
+    Inc(FCurrentCol);
+
+  // Skipping a delimiter should be immediately followed by parsing a cell
+  // without checking for line break first, otherwise we miss last empty cell.
+  // But 0th cell does not start with delimiter unlike other cells, so
+  // the following check is required not to miss the first empty cell:
+  if FCurrentCol > 0 then
+    SkipDelimiter;
+  ParseCell;
+  Result := True;
+end;
+
+{ TCSVBuilder }
+
+function TCSVBuilder.GetDefaultOutputAsString: String;
+var
+  StreamSize: Integer;
+begin
+  Result := '';
+  StreamSize := FDefaultOutput.Size;
+  if StreamSize > 0 then
+  begin
+    SetLength(Result, StreamSize);
+    FDefaultOutput.ReadBuffer(Result[1], StreamSize);
+  end;
+end;
+
+procedure TCSVBuilder.AppendStringToStream(const AString: String; AStream: TStream);
+var
+  StrLen: Integer;
+begin
+  StrLen := Length(AString);
+  if StrLen > 0 then
+    AStream.WriteBuffer(AString[1], StrLen);
+end;
+
+function TCSVBuilder.QuoteCSVString(const AValue: String): String;
+var
+  I: Integer;
+  ValueLen: Integer;
+  NeedQuotation: Boolean;
+begin
+  ValueLen := Length(AValue);
+
+  NeedQuotation := (AValue <> '') and FQuoteOuterWhitespace
+    and ((AValue[1] in WhitespaceChars) or (AValue[ValueLen] in WhitespaceChars));
+
+  if not NeedQuotation then
+    for I := 1 to ValueLen do
+    begin
+      if AValue[I] in FSpecialChars then
+      begin
+        NeedQuotation := True;
+        Break;
+      end;
+    end;
+
+  if NeedQuotation then
+  begin
+    // double existing quotes
+    Result := FDoubleQuote;
+    Insert(StringReplace(AValue, FQuoteChar, FDoubleQuote, [rfReplaceAll]),
+      Result, 2);
+  end else
+    Result := AValue;
+end;
+
+constructor TCSVBuilder.Create;
+begin
+  inherited Create;
+  FDefaultOutput := TMemoryStream.Create;
+  FOutputStream := FDefaultOutput;
+end;
+
+destructor TCSVBuilder.Destroy;
+begin
+  FreeAndNil(FDefaultOutput);
+  inherited Destroy;
+end;
+
+procedure TCSVBuilder.SetOutput(AStream: TStream);
+begin
+  if Assigned(AStream) then
+    FOutputStream := AStream
+  else
+    FOutputStream := FDefaultOutput;
+
+  ResetBuilder;
+end;
+
+procedure TCSVBuilder.ResetBuilder;
+begin
+  if FOutputStream = FDefaultOutput then
+    FDefaultOutput.Clear;
+
+  // Do not clear external FOutputStream because it may be pipe stream
+  // or something else that does not support size and position.
+  // To clear external output is up to the user of TCSVBuilder.
+
+  FNeedLeadingDelimiter := False;
+end;
+
+procedure TCSVBuilder.AppendCell(const AValue: String);
+var
+  CellValue: String;
+begin
+  if FNeedLeadingDelimiter then
+    FOutputStream.WriteBuffer(FDelimiter, CsvCharSize);
+
+  CellValue := ChangeLineEndings(AValue, FLineEnding);
+  CellValue := QuoteCSVString(CellValue);
+  AppendStringToStream(CellValue, FOutputStream);
+
+  FNeedLeadingDelimiter := True;
+end;
+
+procedure TCSVBuilder.AppendRow;
+begin
+  AppendStringToStream(FLineEnding, FOutputStream);
+  FNeedLeadingDelimiter := False;
+end;
+
+end.
+

packages/fcl-base/src/fpexprpars.pp

@@ -195,6 +195,7 @@ Type
   { TFPOrderingOperation }
 
   TFPOrderingOperation = Class(TFPBooleanResultOperation)
+  Public
     Procedure Check; override;
   end;
 
@@ -242,9 +243,9 @@ Type
     FCondition: TFPExprNode;
   protected
     Procedure GetNodeValue(var Result : TFPExpressionResult); override;
+  Public
     Procedure Check; override;
     Function NodeType : TResultType; override;
-  Public
     Constructor Create(ACondition,ALeft,ARight : TFPExprNode);
     Destructor destroy; override;
     Function AsString : string ; override;
@@ -259,9 +260,9 @@ Type
     FCondition: TFPExprNode;
   protected
     Procedure GetNodeValue(var Result : TFPExpressionResult); override;
+  Public
     Procedure Check; override;
     Function NodeType : TResultType; override;
-  Public
     Constructor Create(Args : TExprArgumentArray);
     Destructor destroy; override;
     Function AsString : string ; override;
@@ -271,7 +272,7 @@ Type
   { TMathOperation }
 
   TMathOperation = Class(TFPBinaryOperation)
-  protected
+  Public
     Procedure Check; override;
     Function NodeType : TResultType; override;
   end;
@@ -288,19 +289,17 @@ Type
   { TFPSubtractOperation }
 
   TFPSubtractOperation = Class(TMathOperation)
-  Protected
-    Procedure check; override;
-    Procedure GetNodeValue(var Result : TFPExpressionResult); override;
   Public
+    Procedure Check; override;
+    Procedure GetNodeValue(var Result : TFPExpressionResult); override;
     Function AsString : string ; override;
   end;
 
   { TFPMultiplyOperation }
 
   TFPMultiplyOperation = Class(TMathOperation)
-  Protected
-    Procedure check; override;
   Public
+    Procedure check; override;
     Function AsString : string ; override;
     Procedure GetNodeValue(var Result : TFPExpressionResult); override;
   end;
@@ -308,9 +307,8 @@ Type
   { TFPDivideOperation }
 
   TFPDivideOperation = Class(TMathOperation)
-  Protected
-    Procedure check; override;
   Public
+    Procedure Check; override;
     Function AsString : string ; override;
     Function NodeType : TResultType; override;
     Procedure GetNodeValue(var Result : TFPExpressionResult); override;
@@ -337,16 +335,15 @@ Type
   { TFPNotNode }
 
   TFPNotNode = Class(TFPUnaryOperator)
-  Protected
-    Procedure Check; override;
   Public
+    Procedure Check; override;
     Function NodeType : TResultType;  override;
     Procedure GetNodeValue(var Result : TFPExpressionResult);  override;
     Function AsString : String; override;
   end;
 
   TIntConvertNode = Class(TFPConvertNode)
-  Protected
+  Public
     Procedure Check; override;
   end;
 
@@ -368,9 +365,8 @@ Type
   { TFloatToDateTimeNode }
 
   TFloatToDateTimeNode = Class(TFPConvertNode)
-  Protected
-    Procedure Check; override;
   Public
+    Procedure Check; override;
     Function NodeType : TResultType;  override;
     Procedure GetNodeValue(var Result : TFPExpressionResult);  override;
   end;
@@ -526,8 +522,8 @@ Type
     FargumentParams : TExprParameterArray;
   Protected
     Procedure CalcParams;
-    Procedure Check; override;
   Public
+    Procedure Check; override;
     Constructor CreateFunction(AID : TFPExprIdentifierDef; Const Args : TExprArgumentArray); virtual;
     Destructor Destroy; override;
     Property ArgumentNodes : TExprArgumentArray Read FArgumentNodes;
@@ -601,7 +597,7 @@ Type
   public
     Constructor Create(AOwner :TComponent); override;
     Destructor Destroy; override;
-    Function IdentifierByName(AName : ShortString) : TFPExprIdentifierDef;
+    Function IdentifierByName(const AName : ShortString) : TFPExprIdentifierDef; virtual;
     Procedure Clear;
     Procedure EvaluateExpression(Var Result : TFPExpressionResult);
     Function Evaluate : TFPExpressionResult;
@@ -1047,7 +1043,7 @@ begin
   FDirty:=False;
 end;
 
-function TFPExpressionParser.IdentifierByName(AName: ShortString): TFPExprIdentifierDef;
+function TFPExpressionParser.IdentifierByName(const AName: ShortString): TFPExprIdentifierDef;
 begin
   If FDirty then
     CreateHashList;
@@ -3161,24 +3157,24 @@ end;
 Procedure BuiltInShortDayName(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
 
 begin
-  Result.resString:=ShortDayNames[Args[0].resInteger];
+  Result.resString:=DefaultFormatSettings.ShortDayNames[Args[0].resInteger];
 end;
 
 Procedure BuiltInShortMonthName(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
 
 begin
-  Result.resString:=ShortMonthNames[Args[0].resInteger];
+  Result.resString:=DefaultFormatSettings.ShortMonthNames[Args[0].resInteger];
 end;
 Procedure BuiltInLongDayName(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
 
 begin
-  Result.resString:=LongDayNames[Args[0].resInteger];
+  Result.resString:=DefaultFormatSettings.LongDayNames[Args[0].resInteger];
 end;
 
 Procedure BuiltInLongMonthName(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);
 
 begin
-  Result.resString:=LongMonthNames[Args[0].resInteger];
+  Result.resString:=DefaultFormatSettings.LongMonthNames[Args[0].resInteger];
 end;
 
 Procedure BuiltInFormatDateTime(Var Result : TFPExpressionResult; Const Args : TExprParameterArray);

packages/fcl-base/src/inifiles.pp

@@ -194,8 +194,8 @@ type
     procedure MaybeUpdateFile;
     property Dirty : Boolean Read FDirty;
   public
-    constructor Create(const AFileName: string; AEscapeLineFeeds : Boolean = False); override;
-    constructor Create(AStream: TStream; AEscapeLineFeeds : Boolean = False);
+    constructor Create(const AFileName: string; AEscapeLineFeeds : Boolean = False); overload; override;
+    constructor Create(AStream: TStream; AEscapeLineFeeds : Boolean = False); overload;
     destructor Destroy; override;
     function ReadString(const Section, Ident, Default: string): string; override;
     procedure WriteString(const Section, Ident, Value: String); override;
@@ -212,7 +212,7 @@ type
 
   TMemIniFile = class(TIniFile)
   public
-    constructor Create(const AFileName: string; AEscapeLineFeeds : Boolean = False); override;
+    constructor Create(const AFileName: string; AEscapeLineFeeds : Boolean = False); overload; override;
     procedure Clear;
     procedure GetStrings(List: TStrings);
     procedure Rename(const AFileName: string; Reload: Boolean);
@@ -1056,7 +1056,10 @@ begin
       slLines.SaveToFile(FFileName);
       end
     else if FStream <> nil then
+      begin
+      Fstream.Size:=0;
       slLines.SaveToStream(FStream);
+      end;
     FillSectionList(slLines);
     FDirty := false;
   finally

packages/fcl-base/src/streamex.pp

@@ -1,10 +1,35 @@
+{
+    This file is part of the Free Component Library.
+
+    Copyright (c) 2015 by:
+
+      . Michael Van Canneyt [email protected]
+      . Silvio Clecio github.com/silvioprog
+
+    Text reader classes.
+
+    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.
+
+ **********************************************************************}
+
 {$mode objfpc}
 {$h+}
 unit streamex;
 
 Interface
 
-uses Classes;
+uses
+  Classes, SysUtils, RtlConsts;
+
+const
+  MIN_BUFFER_SIZE = 128;
+  BUFFER_SIZE = 4096;
+  FILE_RIGHTS = 438;
 
 type
 
@@ -58,6 +83,78 @@ type
       property Position: LongInt read GetPosition write SetPosition;
    end;
 
+   { TTextReader }
+
+   TTextReader = class(TObject)
+   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;
+     property Eof: Boolean read IsEof;
+   end;
+
+   { TStreamReader }
+
+   TStreamReader = class(TTextReader)
+   private
+     FBufferRead: Integer;
+     FBufferPosition: Integer;
+     FOwnsStream: Boolean;
+     FStream: TStream;
+     FBuffer: array of Byte;
+     procedure FillBuffer;
+   public
+     constructor Create(AStream: TStream; ABufferSize: Integer;
+       AOwnsStream: Boolean); virtual;
+     constructor Create(AStream: TStream); 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;
+     property BaseStream: TStream read FStream;
+     property OwnsStream: Boolean read FOwnsStream write FOwnsStream;
+   end;
+
+   { TStringReader }
+
+   TStringReader = class(TTextReader)
+   private
+     FReader: TTextReader;
+   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 }
+
+   TFileReader = class(TTextReader)
+   private
+     FReader: TTextReader;
+   public
+     constructor Create(const AFileName: TFileName; AMode: Word;
+       ARights: Cardinal; ABufferSize: Integer); virtual;
+     constructor Create(const AFileName: TFileName; AMode: Word;
+       ABufferSize: Integer); virtual;
+     constructor Create(const AFileName: TFileName; ABufferSize: Integer); virtual;
+     constructor Create(const AFileName: TFileName); 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;
 
   TStreamHelper = class helper for TStream
                      function  ReadWordLE :word;
@@ -192,7 +289,230 @@ begin
    GetDriver.WriteValue(Value);
 end;
 
+{ TTextReader }
+
+constructor TTextReader.Create;
+begin
+  inherited Create;
+end;
+
+{ TStreamReader }
+
+constructor TStreamReader.Create(AStream: TStream; ABufferSize: Integer;
+  AOwnsStream: Boolean);
+begin
+  inherited Create;
+  if not Assigned(AStream) then
+    raise EArgumentException.CreateFmt(SParamIsNil, ['AStream']);
+  FStream := AStream;
+  FOwnsStream := AOwnsStream;
+  if ABufferSize >= MIN_BUFFER_SIZE then
+    SetLength(FBuffer, ABufferSize)
+  else
+    SetLength(FBuffer, MIN_BUFFER_SIZE);
+end;
+
+constructor TStreamReader.Create(AStream: TStream);
+begin
+  Create(AStream, BUFFER_SIZE, False);
+end;
+
+destructor TStreamReader.Destroy;
+begin
+  Close;
+  inherited Destroy;
+end;
+
+procedure TStreamReader.FillBuffer;
+begin
+  FBufferRead := FStream.Read(FBuffer[0], Pred(Length(FBuffer)));
+  FBuffer[FBufferRead] := 0;
+  FBufferPosition := 0;
+end;
+
+procedure TStreamReader.Reset;
+begin
+  FBufferRead := 0;
+  FBufferPosition := 0;
+  if Assigned(FStream) then
+    FStream.Seek(0, 0);
+end;
+
+procedure TStreamReader.Close;
+begin
+  if FOwnsStream then
+  begin
+    FStream.Free;
+    FStream := nil;
+  end;
+end;
+
+function TStreamReader.IsEof: Boolean;
+begin
+  if not Assigned(FStream) then
+    Exit(True);
+  Result := FBufferPosition >= FBufferRead;
+  if Result then
+  begin
+    FillBuffer;
+    Result := FBufferRead = 0;
+  end;
+end;
+
+procedure TStreamReader.ReadLine(out AString: string);
+var
+  VPByte: PByte;
+  VPosition, VStrLength, VLength: Integer;
+begin
+  VPosition := FBufferPosition;
+  SetLength(AString, 0);
+  repeat
+    VPByte := @FBuffer[FBufferPosition];
+    while (FBufferPosition < FBufferRead) and not (VPByte^ in [10, 13]) do
+    begin
+      Inc(VPByte);
+      Inc(FBufferPosition);
+    end;
+    if FBufferPosition = FBufferRead then
+    begin
+      VLength := FBufferPosition - VPosition;
+      if VLength > 0 then
+      begin
+        VStrLength := Length(AString);
+        SetLength(AString, VStrLength + VLength);
+        Move(FBuffer[VPosition], AString[Succ(VStrLength)], VLength);
+      end;
+      FillBuffer;
+      VPosition := FBufferPosition;
+    end;
+  until (FBufferPosition = FBufferRead) or (VPByte^ in [10, 13]);
+  VLength := FBufferPosition - VPosition;
+  if VLength > 0 then
+  begin
+    VStrLength := Length(AString);
+    SetLength(AString, VStrLength + VLength);
+    Move(FBuffer[VPosition], AString[Succ(VStrLength)], VLength);
+  end;
+  if (VPByte^ in [10, 13]) and (FBufferPosition < FBufferRead) then
+  begin
+    Inc(FBufferPosition);
+    if VPByte^ = 13 then
+    begin
+      if FBufferPosition = FBufferRead then
+        FillBuffer;
+      if (FBufferPosition < FBufferRead) and (FBuffer[FBufferPosition] = 10) then
+        Inc(FBufferPosition);
+    end;
+  end;
+end;
+
+function TStreamReader.ReadLine: string;
+begin
+  ReadLine(Result);
+end;
+
+{ TStringReader }
+
+constructor TStringReader.Create(const AString: string; ABufferSize: Integer);
+begin
+  inherited Create;
+  FReader := TStreamReader.Create(TStringStream.Create(AString), ABufferSize, True);
+end;
+
+constructor TStringReader.Create(const AString: string);
+begin
+  Create(AString, BUFFER_SIZE);
+end;
+
+destructor TStringReader.Destroy;
+begin
+  FReader.Free;
+  inherited Destroy;
+end;
+
+procedure TStringReader.Reset;
+begin
+  FReader.Reset;
+end;
+
+procedure TStringReader.Close;
+begin
+  FReader.Close;
+end;
+
+function TStringReader.IsEof: Boolean;
+begin
+  Result := FReader.IsEof;
+end;
+
+procedure TStringReader.ReadLine(out AString: string);
+begin
+  FReader.ReadLine(AString);
+end;
+
+function TStringReader.ReadLine: string;
+begin
+  ReadLine(Result);
+end;
+
+{ TFileReader }
+
+constructor TFileReader.Create(const AFileName: TFileName; AMode: Word;
+  ARights: Cardinal; ABufferSize: Integer);
+begin
+  inherited Create;
+  FReader := TStreamReader.Create(TFileStream.Create(AFileName, AMode, ARights),
+    ABufferSize, True);
+end;
+
+constructor TFileReader.Create(const AFileName: TFileName; AMode: Word;
+  ABufferSize: Integer);
+begin
+  Create(AFileName, AMode, FILE_RIGHTS, ABufferSize);
+end;
+
+constructor TFileReader.Create(const AFileName: TFileName; ABufferSize: Integer);
+begin
+  Create(AFileName, fmOpenRead or fmShareDenyWrite, ABufferSize);
+end;
+
+constructor TFileReader.Create(const AFileName: TFileName);
+begin
+  Create(AFileName, BUFFER_SIZE);
+end;
+
+destructor TFileReader.Destroy;
+begin
+  FReader.Free;
+  inherited Destroy;
+end;
+
+procedure TFileReader.Reset;
+begin
+  FReader.Reset;
+end;
+
+procedure TFileReader.Close;
+begin
+  FReader.Close;
+end;
+
+function TFileReader.IsEof: Boolean;
+begin
+  Result := FReader.IsEof;
+end;
+
+procedure TFileReader.ReadLine(out AString: string);
+begin
+  FReader.ReadLine(AString);
+end;
+
+function TFileReader.ReadLine: string;
+begin
+  ReadLine(Result);
+end;
 
+{ TStreamHelper }
 
 function TStreamHelper.readwordLE:word;
 begin

packages/fcl-db/fpmake.pp

@@ -92,6 +92,13 @@ begin
           AddUnit('dbconst');
         end;
 
+    T:=P.Targets.AddUnit('csvdataset.pp');
+      with T.Dependencies do
+        begin
+        AddUnit('db');
+        AddUnit('bufdataset');
+        end;
+
     T:=P.Targets.AddUnit('bufdataset_parser.pp');
       with T.Dependencies do
         begin

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

@@ -478,7 +478,8 @@ type
 
     FBlobBuffers      : array of PBlobBuffer;
     FUpdateBlobBuffers: array of PBlobBuffer;
-
+    FManualMergeChangeLog : Boolean;
+    
     procedure ProcessFieldsToCompareStruct(const AFields, ADescFields, ACInsFields: TList;
       const AIndexOptions: TIndexOptions; const ALocateOptions: TLocateOptions; out ACompareStruct: TDBCompareStruct);
     function BufferOffset: integer;
@@ -495,7 +496,6 @@ type
     function GetRecordUpdateBufferCached(const ABookmark : TBufBookmark; IncludePrior : boolean = false) : boolean;
     function GetActiveRecordUpdateBuffer : boolean;
     procedure ParseFilter(const AFilter: string);
-    function GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader;
 
     function GetIndexDefs : TIndexDefs;
     function GetIndexFieldNames: String;
@@ -559,6 +559,7 @@ type
     function IsReadFromPacket : Boolean;
     function getnextpacket : integer;
     procedure ActiveBufferToRecord;
+    function GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader; virtual;
     // abstracts, must be overidden by descendents
     function Fetch : boolean; virtual;
     function LoadField(FieldDef : TFieldDef;buffer : pointer; out CreateBlob : boolean) : boolean; virtual;
@@ -597,6 +598,7 @@ type
     property ChangeCount : Integer read GetChangeCount;
     property MaxIndexesCount : Integer read FMaxIndexesCount write SetMaxIndexesCount default 2;
     property ReadOnly : Boolean read FReadOnly write SetReadOnly default false;
+    property ManualMergeChangeLog : Boolean read FManualMergeChangeLog write FManualMergeChangeLog default False;
   published
     property FileName : string read FFileName write FFileName;
     property PacketRecords : Integer read FPacketRecords write SetPacketRecords default 10;
@@ -842,6 +844,7 @@ end;
 constructor TCustomBufDataset.Create(AOwner : TComponent);
 begin
   Inherited Create(AOwner);
+  FManualMergeChangeLog := False;
   FMaxIndexesCount:=2;
   FIndexesCount:=0;
 
@@ -857,8 +860,15 @@ end;
 
 procedure TCustomBufDataset.SetPacketRecords(aValue : integer);
 begin
-  if (aValue = -1) or (aValue > 0) then FPacketRecords := aValue
-    else DatabaseError(SInvPacketRecordsValue);
+  if (aValue = -1) or (aValue > 0) then
+    begin
+    if (IndexFieldNames='') then
+      FPacketRecords := aValue
+    else if AValue<>-1 then
+      DatabaseError(SInvPacketRecordsValueFieldNames);
+    end
+  else
+    DatabaseError(SInvPacketRecordsValue);
 end;
 
 destructor TCustomBufDataset.Destroy;
@@ -1252,7 +1262,7 @@ begin
   InitDefaultIndexes;
   CalcRecordSize;
 
-  FBRecordcount := 0;
+  FBRecordCount := 0;
 
   for IndexNr:=0 to FIndexesCount-1 do with FIndexes[IndexNr] do
     InitialiseSpareRecord(IntAllocRecordBuffer);
@@ -1283,6 +1293,7 @@ var r  : integer;
 begin
   FOpen:=False;
   FReadFromFile:=False;
+  FBRecordCount:=0;
 
   if FIndexesCount>0 then with FIndexes[0] do if IsInitialized then
     begin
@@ -1891,6 +1902,7 @@ begin
       BuildIndex(FIndexes[1]);
       Resync([rmCenter]);
       end;
+    FPacketRecords:=-1;
     FIndexDefs.Updated:=false;
     end
   else
@@ -2416,9 +2428,8 @@ begin
       inc(r);
       end;
   finally
-    if FailedCount = 0 then
+    if (FailedCount=0) and Not ManualMergeChangeLog then
       MergeChangeLog;
-
     InternalGotoBookmark(@StoreCurrRec);
     Resync([]);
     EnableControls;
@@ -2676,7 +2687,10 @@ end;
 
 function TCustomBufDataset.GetRecordCount: Longint;
 begin
-  Result := FBRecordCount;
+  if Active then
+    Result := FBRecordCount
+  else
+    Result:=0;  
 end;
 
 function TCustomBufDataset.UpdateStatus: TUpdateStatus;

packages/fcl-db/src/base/csvdataset.pp

@@ -0,0 +1,399 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2014 by Michael Van Canneyt, member of the
+    Free Pascal development team
+
+    CSV Dataset implementation.
+
+    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 csvdataset;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, bufdataset, csvreadwrite, db, sqldb;
+
+Type
+
+
+  { TCSVOptions }
+
+  TCSVOptions = Class(TCSVHandler)
+  private
+    FDefaultFieldLength: Word;
+    FFirstLineAsFieldNames: Boolean;
+  Public
+    Constructor Create; override;
+    Procedure Assign(Source : TPersistent); override;
+  Published
+    // Does first line of the file contain the field names to use ?
+    property FirstLineAsFieldNames : Boolean Read FFirstLineAsFieldNames Write FFirstLineAsFieldNames;
+    // Default is to create all fields as strings with the same length. Default string field length.
+    // If the CSV dataset has field defs prior to loading, this is ignored.
+    property DefaultFieldLength : Word Read FDefaultFieldLength Write FDefaultFieldLength;
+    // Field delimiter
+    property Delimiter;
+    // Character used to quote "problematic" data
+    // (e.g. with delimiters or spaces in them)
+    // A common quotechar is "
+    property QuoteChar;
+    // String at the end of the line of data (e.g. CRLF)
+    property LineEnding;
+    // Ignore whitespace between delimiters and field data
+    property IgnoreOuterWhitespace;
+    // Use quotes when outer whitespace is found
+    property QuoteOuterWhitespace;
+  end;
+
+  { TCSVDataPacketReader }
+
+  TCSVDataPacketReader = class(TDataPacketReader)
+  private
+    FOptions: TCSVOptions;
+    FOwnsOptions: Boolean;
+    FParser : TCSVParser;
+    FBuilder : TCSVBuilder;
+    FLine : TStringList;
+    FCurrentRow : Integer;
+    FEOF : Boolean;
+    FCreateFieldDefs : TFieldDefs;
+    // Read next row in Fline
+  Protected
+    Procedure ReadNextRow;virtual;
+    procedure SetCreateFieldDefs(AValue: TFieldDefs);virtual;
+  public
+    constructor Create(ADataSet: TCustomBufDataset; AStream : TStream); override;
+    constructor Create(ADataSet: TCustomBufDataset; AStream : TStream; AOptions : TCSVOptions);
+    Destructor Destroy; override;
+    procedure LoadFieldDefs(var AnAutoIncValue : integer); override;
+    procedure StoreFieldDefs(AnAutoIncValue : integer); override;
+    function GetRecordRowState(out AUpdOrder : Integer) : TRowState; override;
+    procedure FinalizeStoreRecords; override;
+    function GetCurrentRecord : boolean; override;
+    procedure GotoNextRecord; override;
+    procedure InitLoadRecords; override;
+    procedure RestoreRecord; override;
+    procedure StoreRecord(ARowState : TRowState; AUpdOrder : integer = 0); override;
+    class function RecognizeStream(AStream : TStream) : boolean; override;
+    Property Options : TCSVOptions Read FOptions;
+    Property CreateFieldDefs : TFieldDefs read FCreateFieldDefs Write SetCreateFieldDefs;
+  end;
+
+  { TCustomCSVDataset }
+
+  TCustomCSVDataset = Class(TBufDataset)
+  private
+    FCSVOptions: TCSVOptions;
+    procedure SetCSVOptions(AValue: TCSVOptions);
+  Protected
+    function GetPacketReader(const Format: TDataPacketFormat; const AStream: TStream): TDataPacketReader; override;
+    procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField); override;
+    procedure InternalInitFieldDefs; override;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    { If FieldDefs is filled prior to calling one of the load functions,
+      the fielddefs definitions will be checked against file contents
+      as far as possible: count and names if names are on first line}
+    procedure LoadFromCSVStream(AStream : TStream);
+    procedure LoadFromCSVFile(Const AFileName: string);
+    procedure SaveToCSVStream(AStream : TStream);
+    procedure SaveToCSVFile(AFileName: string = '');
+  Protected
+    Property CSVOptions : TCSVOptions Read FCSVOptions Write SetCSVOptions;
+  end;
+
+  TCSVDataset = Class(TCustomCSVDataset)
+  Published
+    Property CSVOptions;
+  end;
+
+implementation
+
+{ TCSVDataPacketReader }
+
+procedure TCSVDataPacketReader.ReadNextRow;
+
+
+begin
+  FLine.Clear;
+  if not FEOF then
+    begin
+    if (FCurrentRow>0) then
+      FLine.Add(FParser.CurrentCellText);
+    Repeat
+      FEOF:=Not FParser.ParseNextCell;
+      if (not FEOF) and (FParser.CurrentRow=FCurrentRow) then
+        FLine.Add(FParser.CurrentCellText);
+    until FEOF or (FParser.CurrentRow>FCurrentRow);
+    end;
+  FCurrentRow:=FParser.CurrentRow;
+end;
+
+procedure TCSVDataPacketReader.SetCreateFieldDefs(AValue: TFieldDefs);
+begin
+  if FCreateFieldDefs=AValue then Exit;
+  if (FCreateFieldDefs=Nil) then
+    begin
+    FCreateFieldDefs:=TFieldDefs.Create(AValue.Dataset);
+    FCreateFieldDefs.Assign(AValue);
+    end;
+end;
+
+constructor TCSVDataPacketReader.Create(ADataSet: TCustomBufDataset; AStream: TStream);
+begin
+  inherited Create(ADataSet,AStream);
+  if FOptions=Nil then
+    begin
+    FOptions:=TCSVOptions.Create;
+    FOptions.FFirstLineAsFieldNames:=True;
+    FOwnsOptions:=True;
+    end;
+  FLine:=TStringList.Create;
+end;
+
+constructor TCSVDataPacketReader.Create(ADataSet: TCustomBufDataset; AStream: TStream; AOptions: TCSVOptions);
+begin
+  FOptions:=AOptions;
+  Create(ADataset,AStream);
+  FOwnsOptions:=AOptions=Nil;
+end;
+
+destructor TCSVDataPacketReader.Destroy;
+begin
+  If FOwnsOptions then
+    FreeAndNil(FOPtions);
+  FreeAndNil(Fline);
+  inherited Destroy;
+end;
+
+procedure TCSVDataPacketReader.LoadFieldDefs(var AnAutoIncValue: integer);
+Var
+  FN : String;
+  I : Integer;
+
+begin
+  FParser:=TCSVParser.Create;
+  FParser.SetSource(Stream);
+  FCurrentRow:=0;
+  ReadNextRow;
+  If Assigned(CreateFieldDefs) then
+   begin
+   if (CreateFieldDefs.Count<>Fline.Count) then
+     DatabaseErrorFmt('CSV File Field count (%d) does not match dataset field count (%d).',[Fline.Count,CreateFieldDefs.Count],Dataset.FieldDefs.Dataset);
+   If FOptions.FirstLineAsFieldNames then
+     For I:=0 to FLine.Count-1 do
+       If (CompareText(FLine[i],CreateFieldDefs[i].Name)<>0) then
+         DatabaseErrorFmt('CSV File field %d: name "%s" does not match dataset field name "%s".',[I,FLine[i],CreateFieldDefs[i].Name],Dataset.FieldDefs.Dataset);
+   Dataset.FieldDefs.Assign(CreateFieldDefs);
+   end
+  else if (FLine.Count>0) then
+    For I:=0 to FLine.Count-1 do
+      begin
+      If FOptions.FirstLineAsFieldNames then
+        FN:=FLine[i]
+      else
+        FN:=Format('Column%d',[i+1]);
+      Dataset.FieldDefs.Add(FN,ftString,Foptions.DefaultFieldLength);
+      end;
+  if FOptions.FirstLineAsFieldNames then
+   ReadNextRow;
+end;
+
+procedure TCSVDataPacketReader.StoreFieldDefs(AnAutoIncValue: integer);
+
+Var
+  I : Integer;
+
+begin
+  FBuilder:=TCSVBuilder.Create;
+  FBuilder.SetOutput(Stream);
+  if FOptions.FirstLineAsFieldNames then
+    begin
+    For I:=0 to Dataset.FieldDefs.Count-1 do
+      FBuilder.AppendCell(Dataset.FieldDefs[i].Name);
+    FBuilder.AppendRow;
+    end;
+end;
+
+function TCSVDataPacketReader.GetRecordRowState(out AUpdOrder: Integer
+  ): TRowState;
+begin
+  AUpdOrder:=0;
+  Result:=[];
+end;
+
+procedure TCSVDataPacketReader.FinalizeStoreRecords;
+begin
+
+end;
+
+function TCSVDataPacketReader.GetCurrentRecord: boolean;
+begin
+  Result:=Fline.Count>0;
+end;
+
+procedure TCSVDataPacketReader.GotoNextRecord;
+begin
+  ReadNextRow;
+end;
+
+procedure TCSVDataPacketReader.InitLoadRecords;
+begin
+   // Do nothing
+end;
+
+procedure TCSVDataPacketReader.RestoreRecord;
+
+Var
+  I : integer;
+
+begin
+  For I:=0 to Fline.Count-1 do
+    Dataset.Fields[i].AsString:=Copy(FLine[i],1,Dataset.Fields[i].Size)
+end;
+
+procedure TCSVDataPacketReader.StoreRecord(ARowState: TRowState; AUpdOrder: integer);
+Var
+  I : integer;
+
+begin
+  For I:=0 to Dataset.Fields.Count-1 do
+    FBuilder.AppendCell(Dataset.Fields[i].AsString);
+  FBuilder.AppendRow;
+end;
+
+class function TCSVDataPacketReader.RecognizeStream(AStream: TStream): boolean;
+begin
+  Result:=False;
+end;
+
+{ TCSVOptions }
+
+Constructor TCSVOptions.Create;
+begin
+  inherited Create;
+  DefaultFieldLength:=255;
+end;
+
+Procedure TCSVOptions.Assign(Source: TPersistent);
+begin
+  if (Source is TCSVOptions) then
+    begin
+    FFirstLineAsFieldNames:=TCSVOptions(Source).FirstLineAsFieldNames;
+    FDefaultFieldLength:=TCSVOptions(Source).FDefaultFieldLength
+    end;
+  inherited Assign(Source);
+end;
+
+{ TCustomCSVDataset }
+
+procedure TCustomCSVDataset.SetCSVOptions(AValue: TCSVOptions);
+begin
+  if (FCSVOptions=AValue) then Exit;
+  FCSVOptions.Assign(AValue);
+end;
+
+function TCustomCSVDataset.GetPacketReader(const Format: TDataPacketFormat;
+  const AStream: TStream): TDataPacketReader;
+begin
+  If (Format=dfAny) then
+    Result:=TCSVDataPacketReader.Create(Self,AStream,FCSVOptions)
+  else
+    Result:=Inherited GetPacketReader(Format,AStream);
+end;
+
+procedure TCustomCSVDataset.LoadBlobIntoBuffer(FieldDef: TFieldDef;
+  ABlobBuf: PBufBlobField);
+begin
+  // Do nothing
+end;
+
+procedure TCustomCSVDataset.InternalInitFieldDefs;
+begin
+  // Do nothing
+end;
+
+constructor TCustomCSVDataset.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FCSVOptions:=TCSVOptions.Create;
+end;
+
+destructor TCustomCSVDataset.Destroy;
+begin
+  FreeAndNil(FCSVOptions);
+  inherited Destroy;
+end;
+
+procedure TCustomCSVDataset.LoadFromCSVStream(AStream: TStream);
+
+Var
+  P : TCSVDataPacketReader;
+
+begin
+  CheckInactive;
+  P:=TCSVDataPacketReader.Create(Self,AStream,FCSVOptions);
+  try
+    if FieldDefs.Count>0 then
+     P.CreateFieldDefs:=FieldDefs;
+    SetDatasetPacket(P);
+  finally
+    P.Free;
+  end;
+end;
+
+procedure TCustomCSVDataset.LoadFromCSVFile(const AFileName: string);
+
+Var
+  F : TFileStream;
+
+begin
+  F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
+  try
+    LoadFromCSVStream(F);
+  finally
+    F.Free;
+  end;
+end;
+
+procedure TCustomCSVDataset.SaveToCSVStream(AStream: TStream);
+
+Var
+  P : TCSVDataPacketReader;
+
+begin
+  First;
+  MergeChangeLog;
+  P:=TCSVDataPacketReader.Create(Self,AStream,FCSVOPtions);
+  try
+    GetDatasetPacket(P);
+  finally
+    P.Free;
+  end;
+end;
+
+procedure TCustomCSVDataset.SaveToCSVFile(AFileName: string);
+Var
+  F : TFileStream;
+
+begin
+  F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
+  try
+    SaveToCSVStream(F);
+  finally
+    F.Free;
+  end;
+end;
+
+end.
+

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

@@ -40,10 +40,10 @@ end;
 
 procedure TDatabase.DoDisconnect;
 begin
-  Closedatasets;
-  Closetransactions;
+  CloseDatasets;
+  CloseTransactions;
   DoInternalDisConnect;
-  if csloading in ComponentState then
+  if csLoading in ComponentState then
     FOpenAfterRead := false;
   FConnected := False;
 end;
@@ -95,7 +95,12 @@ begin
   If Assigned(FTransactions) then
     begin
     For I:=FTransactions.Count-1 downto 0 do
-      TDBTransaction(FTransactions[i]).EndTransaction;
+      try
+        TDBTransaction(FTransactions[i]).EndTransaction;
+      except
+        if not ForcedClose then
+          Raise;
+      end;    
     end;
 end;
 
@@ -217,7 +222,7 @@ end;
 
 
 { ---------------------------------------------------------------------
-    TDBdataset
+    TDBDataset
   ---------------------------------------------------------------------}
 
 Procedure TDBDataset.SetDatabase (Value : TDatabase);
@@ -345,7 +350,7 @@ begin
   FActive := false;
 end;
 
-procedure TDBTransaction.openTrans;
+procedure TDBTransaction.OpenTrans;
 
 begin
   FActive := true;
@@ -368,7 +373,7 @@ end;
 constructor TDBTransaction.Create(AOwner: TComponent);
 
 begin
-  inherited create(AOwner);
+  inherited Create(AOwner);
   FDatasets:=TList.Create;
 end;
 
@@ -403,7 +408,7 @@ begin
     end;
 end;
 
-destructor TDBTransaction.destroy;
+destructor TDBTransaction.Destroy;
 
 begin
   Database:=Nil;
@@ -423,25 +428,25 @@ begin
       TDBDataset(FDataSets[i]).Transaction:=Nil;
 end;
 
-function TDBTransaction.GetDataSetCount: Longint;
+function TDBTransaction.GetDataset(Index: longint): TDBDataset;
 
 begin
-  If Assigned(FDatasets) Then
-    Result:=FDatasets.Count
+  If Assigned(FDatasets) then
+    Result:=TDBDataset(FDatasets[Index])
   else
-    Result:=0;
+  begin
+    Result := nil;
+    DatabaseError(SNoDatasets);
+  end;
 end;
 
-procedure TDBTransaction.UnRegisterDataset (DS : TDBDataset);
-
-Var I : longint;
+function TDBTransaction.GetDataSetCount: Longint;
 
 begin
-  I:=FDatasets.IndexOf(DS);
-  If I<>-1 then
-    FDatasets.Delete(I)
+  If Assigned(FDatasets) Then
+    Result:=FDatasets.Count
   else
-    DatabaseErrorFmt(SNoDatasetRegistered,[DS.Name]);
+    Result:=0;
 end;
 
 procedure TDBTransaction.RegisterDataset (DS : TDBDataset);
@@ -456,27 +461,22 @@ begin
     DatabaseErrorFmt(SDatasetRegistered,[DS.Name]);
 end;
 
-function TDBTransaction.GetDataset(Index: longint): TDBDataset;
+procedure TDBTransaction.UnRegisterDataset (DS : TDBDataset);
+
+Var I : longint;
 
 begin
-  If Assigned(FDatasets) then
-    Result:=TDBDataset(FDatasets[Index])
+  I:=FDatasets.IndexOf(DS);
+  If I<>-1 then
+    FDatasets.Delete(I)
   else
-  begin
-    result := nil;
-    DatabaseError(SNoDatasets);
-  end;
+    DatabaseErrorFmt(SNoDatasetRegistered,[DS.Name]);
 end;
 
 { ---------------------------------------------------------------------
     TCustomConnection
   ---------------------------------------------------------------------}
 
-procedure TCustomConnection.SetAfterConnect(const AValue: TNotifyEvent);
-begin
-  FAfterConnect:=AValue;
-end;
-
 function TCustomConnection.GetDataSet(Index: Longint): TDataSet;
 begin
   Result := nil;
@@ -495,6 +495,11 @@ begin
     ShowException(ExceptObject,ExceptAddr);
 end;
 
+procedure TCustomConnection.SetAfterConnect(const AValue: TNotifyEvent);
+begin
+  FAfterConnect:=AValue;
+end;
+
 procedure TCustomConnection.SetAfterDisconnect(const AValue: TNotifyEvent);
 begin
   FAfterDisconnect:=AValue;
@@ -505,7 +510,30 @@ begin
   FBeforeConnect:=AValue;
 end;
 
+procedure TCustomConnection.SetBeforeDisconnect(const AValue: TNotifyEvent);
+begin
+  FBeforeDisconnect:=AValue;
+end;
+
+procedure TCustomConnection.DoLoginPrompt;
+
+var
+  ADatabaseName, AUserName, APassword: string;
+
+begin
+  if FLoginPrompt then
+    begin
+    GetLoginParams(ADatabaseName, AUserName, APassword);
+    if Assigned(FOnLogin) then
+      FOnLogin(Self, AUserName, APassword)
+    else if Assigned(LoginDialogExProc) then
+      LoginDialogExProc(ADatabaseName, AUserName, APassword, False);
+    SetLoginParams(ADatabaseName, AUserName, APassword);
+    end;
+end;
+
 procedure TCustomConnection.SetConnected(Value: boolean);
+
 begin
   If Value<>Connected then
     begin
@@ -520,8 +548,7 @@ begin
         begin
         if Assigned(BeforeConnect) then
           BeforeConnect(self);
-        if FLoginPrompt then if assigned(FOnLogin) then
-          FOnLogin(self,'','');
+        DoLoginPrompt;
         DoConnect;
         if Assigned(AfterConnect) then
           AfterConnect(self);
@@ -538,9 +565,24 @@ begin
     end;
 end;
 
-procedure TCustomConnection.SetBeforeDisconnect(const AValue: TNotifyEvent);
+procedure TCustomConnection.GetLoginParams(out ADatabaseName, AUserName, APassword: string);
 begin
-  FBeforeDisconnect:=AValue;
+  if IsPublishedProp(Self,'DatabaseName') then
+    ADatabaseName := GetStrProp(Self,'DatabaseName');
+  if IsPublishedProp(Self,'UserName') then
+    AUserName := GetStrProp(Self,'UserName');
+  if IsPublishedProp(Self,'Password') then
+    APassword := 'Password';
+end;
+
+procedure TCustomConnection.SetLoginParams(const ADatabaseName, AUserName, APassword: string);
+begin
+  if IsPublishedProp(Self,'DatabaseName') then
+    SetStrProp(Self,'DatabaseName',ADatabaseName);
+  if IsPublishedProp(Self,'UserName') then
+    SetStrProp(Self,'UserName',AUserName);
+  if IsPublishedProp(Self,'Password') then
+    SetStrProp(Self,'Password',APassword);
 end;
 
 procedure TCustomConnection.DoConnect;

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

@@ -90,39 +90,37 @@ begin
   FCalcFieldsSize := 0;
   FBlobFieldCount := 0;
   for i := 0 to Fields.Count - 1 do
-    with Fields[i] do begin
+    with Fields[i] do
+      begin
       FFieldDef:=Nil;
-      if Binding then begin
-        if FieldKind in [fkCalculated, fkLookup] then begin
-          FFieldNo := -1;
-          FOffset := FCalcFieldsSize;
-          Inc(FCalcFieldsSize, DataSize + 1);
-          if FieldKind in [fkLookup] then begin
-            if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
-               (FLookupResultField = '') or (FKeyFields = '')) then
-              DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
-            FFields.CheckFieldNames(FKeyFields);
-            FLookupDataSet.Open;
-            FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
-            FLookupDataSet.FieldByName(FLookupResultField);
-            if FLookupCache then RefreshLookupList;
-          end
-        end else begin
-          FFieldDef := nil;
-          FieldIndex := FieldDefs.IndexOf(Fields[i].FieldName);
-          if FieldIndex <> -1 then begin
-            FFieldDef := FieldDefs[FieldIndex];
-            FFieldNo := FFieldDef.FieldNo;
-            if FieldDef.InternalCalcField then FInternalCalcFields := True;
-            if IsBlob then begin
-              FSize := FFieldDef.Size;
-              FOffset := FBlobFieldCount;
-              Inc(FBlobFieldCount);
+      if not Binding then
+        FFieldNo := 0
+      else if FieldKind in [fkCalculated, fkLookup] then
+        begin
+        FFieldNo := -1;
+        FOffset := FCalcFieldsSize;
+        Inc(FCalcFieldsSize, DataSize + 1);
+        end
+      else
+        begin
+        FFieldDef := nil;
+        FieldIndex := FieldDefs.IndexOf(Fields[i].FieldName);
+        if FieldIndex <> -1 then
+          begin
+          FFieldDef := FieldDefs[FieldIndex];
+          FFieldNo := FFieldDef.FieldNo;
+          if FieldDef.InternalCalcField then
+            FInternalCalcFields := True;
+          if IsBlob then
+            begin
+            FSize := FFieldDef.Size;
+            FOffset := FBlobFieldCount;
+            Inc(FBlobFieldCount);
             end;
-          end else FFieldNo := 0;
+          end
         end;
-      end else FFieldNo := 0;
-    end;
+      Bind(Binding);
+      end;
 end;
 
 function TDataSet.BookmarkAvailable: Boolean;
@@ -2482,3 +2480,30 @@ end;
 
 {------------------------------------------------------------------------------}
 
+operator Enumerator(ADataSet: TDataSet): TDataSetEnumerator;
+begin
+ Result:=TDataSetEnumerator.Create(ADataSet);
+end;
+
+constructor TDataSetEnumerator.Create(ADataSet: TDataSet);
+begin
+  inherited Create;
+  FDataSet:=ADataSet;
+  FBOF:=True;
+  FDataSet.First;
+end;
+
+function TDataSetEnumerator.GetCurrent: TFields;
+begin
+  Result := FDataSet.Fields;
+end;
+
+function TDataSetEnumerator.MoveNext: Boolean;
+
+begin
+  if FBOF then
+    FBOF:=False
+  else
+    FDataSet.Next;
+  Result:=not FDataSet.EOF;
+end;

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

@@ -178,7 +178,7 @@ type
     procedure SetSize(const AValue: Integer);
     procedure SetRequired(const AValue: Boolean);
   public
-    constructor create(ACollection : TCollection); override;
+    constructor Create(ACollection : TCollection); override;
     constructor Create(AOwner: TFieldDefs; const AName: string;
       ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint); overload;
     destructor Destroy; override;
@@ -191,8 +191,8 @@ type
   Published
     property Attributes: TFieldAttributes read FAttributes write SetAttributes default [];
     property DataType: TFieldType read FDataType write SetDataType;
-    property Precision: Longint read FPrecision write SetPrecision;
-    property Size: Integer read FSize write SetSize;
+    property Precision: Longint read FPrecision write SetPrecision default 0;
+    property Size: Integer read FSize write SetSize default 0;
   end;
   TFieldDefClass = Class of TFieldDef;
 
@@ -314,7 +314,8 @@ type
     procedure SetLookup(const AValue: Boolean);
     procedure SetReadOnly(const AValue: Boolean);
     procedure SetVisible(const AValue: Boolean);
-    function IsDisplayStored : Boolean;
+    function IsDisplayLabelStored : Boolean;
+    function IsDisplayWidthStored: Boolean;
     function GetLookupList: TLookupList;
     procedure CalcLookupValue;
   protected
@@ -322,6 +323,7 @@ type
     procedure CheckInactive;
     class procedure CheckTypeSize(AValue: Longint); virtual;
     procedure Change; virtual;
+    procedure Bind(Binding: Boolean); virtual;
     procedure DataChanged;
     procedure FreeBuffers; virtual;
     function GetAsBCD: TBCD; virtual;
@@ -427,8 +429,8 @@ type
     property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
     property ConstraintErrorMessage: string read FConstraintErrorMessage write FConstraintErrorMessage;
     property DefaultExpression: string read FDefaultExpression write FDefaultExpression;
-    property DisplayLabel : string read GetDisplayName write SetDisplayLabel stored IsDisplayStored;
-    property DisplayWidth: Longint read GetDisplayWidth write SetDisplayWidth;
+    property DisplayLabel : string read GetDisplayName write SetDisplayLabel stored IsDisplayLabelStored;
+    property DisplayWidth: Longint read GetDisplayWidth write SetDisplayWidth stored IsDisplayWidthStored;
     property FieldKind: TFieldKind read FFieldKind write FFieldKind;
     property FieldName: string read FFieldName write FFieldName;
     property HasConstraints: Boolean read FHasConstraints;
@@ -637,6 +639,7 @@ type
     procedure SetCurrency(const AValue: Boolean);
     procedure SetPrecision(const AValue: Longint);
   protected
+    function GetAsBCD: TBCD; override;
     function GetAsFloat: Double; override;
     function GetAsLargeInt: LargeInt; override;
     function GetAsInteger: Longint; override;
@@ -644,6 +647,7 @@ type
     function GetAsString: string; override;
     function GetDataSize: Integer; override;
     procedure GetText(var theText: string; ADisplayText: Boolean); override;
+    procedure SetAsBCD(const AValue: TBCD); override;
     procedure SetAsFloat(AValue: Double); override;
     procedure SetAsLargeInt(AValue: LargeInt); override;
     procedure SetAsInteger(AValue: Longint); override;
@@ -849,7 +853,7 @@ type
     function CheckRange(AValue : TBCD) : Boolean;
     property Value: TBCD read GetAsBCD write SetAsBCD;
   published
-    property Precision: Longint read FPrecision write FPrecision default 15;
+    property Precision: Longint read FPrecision write FPrecision default 18;
     property Currency: Boolean read FCurrency write FCurrency;
     property MaxValue: string read GetMaxValue write SetMaxValue;
     property MinValue: string read GetMinValue write SetMinValue;
@@ -862,8 +866,7 @@ type
   // This type is needed for compatibility. While it should contain only blob
   // types, it actually does not.
   // Instead of this, please use ftBlobTypes
-  TBlobType = ftBlob..ftWideMemo deprecated
-    'Warning: Does not contain BLOB types. Please use ftBlobTypes.';
+  TBlobType = ftBlob..ftWideMemo deprecated 'Warning: Does not contain BLOB types. Please use ftBlobTypes.';
 
   TBlobField = class(TField)
   private
@@ -872,7 +875,7 @@ type
     Function GetBlobStream (Mode : TBlobStreamMode) : TStream;
     // Wrapper that retrieves FDataType as a TBlobType
     function GetBlobType: TBlobType;
-    // Wrapper that calls SetFieldtype
+    // Wrapper that calls SetFieldType
     procedure SetBlobType(AValue: TBlobType);
   protected
     procedure FreeBuffers; override;
@@ -902,7 +905,7 @@ type
     property Value: string read GetAsString write SetAsString;
     property Transliterate: Boolean read FTransliterate write FTransliterate;
   published
-    property BlobType: TBlobType read GetBlobType write SetBlobType;
+    property BlobType: TBlobType read GetBlobType write SetBlobType default ftBlob;
     property Size default 0;
   end;
 
@@ -1711,6 +1714,19 @@ type
     property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;
   end;
 
+  TDataSetEnumerator = class
+  private
+    FDataSet: TDataSet;
+    FBOF: Boolean;
+    function GetCurrent: TFields;
+  public  
+    constructor Create(ADataSet: TDataSet);
+    function MoveNext: Boolean;
+    property Current: TFields read GetCurrent;
+  end;
+
+{ TDataLink }
+
   TDataLink = class(TPersistent)
   private
     FFirstRecord,
@@ -1898,7 +1914,7 @@ type
     Function AllowClose(DS: TDBDataset): Boolean; virtual;
     Procedure SetDatabase (Value : TDatabase); virtual;
     procedure CloseTrans;
-    procedure openTrans;
+    procedure OpenTrans;
     Procedure CheckDatabase;
     Procedure CheckActive;
     Procedure CheckInactive;
@@ -1912,7 +1928,7 @@ type
     procedure Loaded; override;
   Public
     constructor Create(AOwner: TComponent); override;
-    Destructor destroy; override;
+    Destructor Destroy; override;
     procedure CloseDataSets;
     Property DataBase : TDatabase Read FDatabase Write SetDatabase;
   published
@@ -1938,16 +1954,19 @@ type
     procedure SetBeforeConnect(const AValue: TNotifyEvent);
     procedure SetBeforeDisconnect(const AValue: TNotifyEvent);
   protected
+    procedure DoLoginPrompt; virtual;
     procedure DoConnect; virtual;
     procedure DoDisconnect; virtual;
     function GetConnected : boolean; virtual;
     Function GetDataset(Index : longint) : TDataset; virtual;
     Function GetDataSetCount : Longint; virtual;
+    procedure GetLoginParams(out ADatabaseName, AUserName, APassword: string); virtual;
     procedure InternalHandleException; virtual;
     procedure Loaded; override;
     procedure SetConnected (Value : boolean); virtual;
+    procedure SetLoginParams(const ADatabaseName, AUserName, APassword: string); virtual;
     property ForcedClose : Boolean read FForcedClose write FForcedClose;
-    property Streamedconnected: Boolean read FStreamedConnected write FStreamedConnected;
+    property StreamedConnected: Boolean read FStreamedConnected write FStreamedConnected;
   public
     procedure Close(ForceClose: Boolean=False);
     destructor Destroy; override;
@@ -2166,12 +2185,16 @@ const
   ftBlobTypes = [ftBlob, ftMemo, ftGraphic, ftFmtMemo, ftParadoxOle,
     ftDBaseOle, ftTypedBinary, ftOraBlob, ftOraClob, ftWideMemo];
 
+var
+  LoginDialogExProc: function(const ADatabaseName: string; var AUserName, APassword: string; UserNameReadOnly: Boolean): Boolean = nil;
+
+
 { Auxiliary functions }
 
 Procedure DatabaseError (Const Msg : String); overload;
 Procedure DatabaseError (Const Msg : String; Comp : TComponent); overload;
-Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of Const); overload;
-Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of const; Comp : TComponent); overload;
+Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const); overload;
+Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const; Comp : TComponent); overload;
 Function ExtractFieldName(Const Fields: String; var Pos: Integer): String;
 Function DateTimeRecToDateTime(DT: TFieldType; Data: TDateTimeRec): TDateTime;
 Function DateTimeToDateTimeRec(DT: TFieldType; Data: TDateTime): TDateTimeRec;
@@ -2181,6 +2204,8 @@ function BuffersEqual(Buf1, Buf2: Pointer; Size: Integer): Boolean;
 
 function SkipComments(var p: PChar; EscapeSlash, EscapeRepeat : Boolean) : boolean;
 
+operator Enumerator(ADataSet: TDataSet): TDataSetEnumerator;
+ 
 implementation
 
 uses dbconst,typinfo;
@@ -2204,13 +2229,13 @@ begin
     DatabaseError(Msg);
 end;
 
-Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of Const);
+Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const);
 
 begin
   Raise EDatabaseError.CreateFmt(Fmt,Args);
 end;
 
-Procedure DatabaseErrorFmt (Const Fmt : String; Args : Array Of const;
+Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const;
                             Comp : TComponent);
 begin
   if assigned(comp) then

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

@@ -22,7 +22,7 @@ Resourcestring
   SActiveDataset           = 'Operation cannot be performed on an active dataset';
   SBadParamFieldType       = 'Bad fieldtype for parameter "%s".';
   SCantSetAutoIncFields    = 'AutoInc Fields are read-only';
-  SConnected               = 'Operation cannot be performed on an connected database';
+  SConnected               = 'Operation cannot be performed on a connected database';
   SDatasetReadOnly         = 'Dataset is read-only.';
   SDatasetRegistered       = 'Dataset already registered : "%s"';
   SDuplicateFieldName      = 'Duplicate fieldname : "%s"';
@@ -83,6 +83,7 @@ Resourcestring
   SLookupInfoError         = 'Lookup information for field ''%s'' is incomplete';
   SUnsupportedFieldType    = 'Fieldtype %s is not supported';
   SInvPacketRecordsValue   = 'PacketRecords has to be larger then 0';
+  SInvPacketRecordsValueFieldNames = 'PacketRecords must be -1 if IndexFieldNames is set';
   SInvalidSearchFieldType  = 'Searching in fields of type %s is not supported';
   SDatasetEmpty            = 'The dataset is empty';
   SFieldIsNull             = 'The field is null';
@@ -121,6 +122,7 @@ Resourcestring
   SErrRefreshNotSingleton     = 'Refresh SQL resulted in multiple records: %d.';
   SErrRefreshEmptyResult      = 'Refresh SQL resulted in empty result set.';
   SErrNoKeyFieldForRefreshClause = 'No key field found to construct refresh SQL WHERE clause';
+  SErrFailedToFetchReturningResult = 'Failed to fetch returning result';
 
 Implementation
 

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

@@ -99,11 +99,9 @@ begin
     Result.FFieldNo:=Self.FieldNo;
     Result.SetFieldType(DataType);
     Result.FReadOnly:=(faReadOnly in Attributes);
-{$ifdef dsdebug}
-    Writeln ('TFieldDef.CreateField : Trying to set dataset');
-{$endif dsdebug}
 {$ifdef dsdebug}
     Writeln ('TFieldDef.CreateField : Result Fieldno : ',Result.FieldNo,'; Self : ',FieldNo);
+    Writeln ('TFieldDef.CreateField : Trying to set dataset');
 {$endif dsdebug}
     Result.Dataset:=TFieldDefs(Collection).Dataset;
     If (Result is TFloatField) then
@@ -384,6 +382,23 @@ begin
     end;
 end;
 
+procedure TField.Bind(Binding: Boolean);
+
+begin
+  if Binding and (FieldKind=fkLookup) then
+    begin
+    if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
+       (FLookupResultField = '') or (FKeyFields = '')) then
+      DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
+    FFields.CheckFieldNames(FKeyFields);
+    FLookupDataSet.Open;
+    FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
+    FLookupDataSet.FieldByName(FLookupResultField);
+    if FLookupCache then
+      RefreshLookupList;
+    end;
+end;
+
 procedure TField.Change;
 
 begin
@@ -401,8 +416,7 @@ end;
 procedure TField.Clear;
 
 begin
-  if FieldKind in [fkData, fkInternalCalc] then
-    SetData(Nil);
+  SetData(Nil);
 end;
 
 procedure TField.DataChanged;
@@ -609,12 +623,18 @@ begin
     Result:=FFieldName;
 end;
 
-function TField.IsDisplayStored: Boolean;
+function TField.IsDisplayLabelStored: Boolean;
 
 begin
   Result:=(DisplayLabel<>FieldName);
 end;
 
+Function TField.IsDisplayWidthStored : Boolean;
+
+begin
+  Result:=(FDisplayWidth<>0);
+end;
+
 function TField.GetLookupList: TLookupList;
 begin
   if not Assigned(FLookupList) then
@@ -1027,7 +1047,7 @@ end;
 
 procedure TStringField.SetFieldType(AValue: TFieldType);
 begin
-  if avalue in [ftString, ftFixedChar] then
+  if AValue in [ftString, ftFixedChar] then
     SetDataType(AValue);
 end;
 
@@ -1244,7 +1264,7 @@ end;
 
 procedure TWideStringField.SetFieldType(AValue: TFieldType);
 begin
-  if avalue in [ftWideString, ftFixedWideChar] then
+  if AValue in [ftWideString, ftFixedWideChar] then
     SetDataType(AValue);
 end;
 
@@ -1385,7 +1405,7 @@ constructor TLongintField.Create(AOwner: TComponent);
 
 begin
   Inherited Create(AOwner);
-  SetDatatype(ftinteger);
+  SetDataType(ftInteger);
   FMinRange:=Low(LongInt);
   FMaxRange:=High(LongInt);
   FValidchars:=['+','-','0'..'9'];
@@ -1486,7 +1506,6 @@ begin
 end;
 
 procedure TLongintField.SetAsInteger(AValue: Longint);
-var Min, Max: Longint;
 begin
   If CheckRange(AValue) then
     SetData(@AValue)
@@ -1555,7 +1574,7 @@ constructor TLargeintField.Create(AOwner: TComponent);
 
 begin
   Inherited Create(AOwner);
-  SetDatatype(ftLargeint);
+  SetDataType(ftLargeint);
   FMinRange:=Low(Largeint);
   FMaxRange:=High(Largeint);
   FValidchars:=['+','-','0'..'9'];
@@ -1778,6 +1797,15 @@ begin
     FPrecision := 2;
 end;
 
+function TFloatField.GetAsBCD: TBCD;
+var f : Double;
+begin
+  if GetData(@f) then
+    Result := DoubleToBCD(f)
+  else
+    Result := NullBCD;
+end;
+
 function TFloatField.GetAsFloat: Double;
 
 begin
@@ -1809,11 +1837,11 @@ end;
 
 function TFloatField.GetAsString: string;
 
-var R : Double;
+var f : Double;
 
 begin
-  If GetData(@R) then
-    Result:=FloatToStr(R)
+  If GetData(@f) then
+    Result:=FloatToStr(f)
   else
     Result:='';
 end;
@@ -1859,6 +1887,11 @@ begin
     TheText:=FloatToStrF(E,ff,FPrecision,Digits);
 end;
 
+procedure TFloatField.SetAsBCD(const AValue: TBCD);
+begin
+  SetAsFloat(BCDToDouble(AValue));
+end;
+
 procedure TFloatField.SetAsFloat(AValue: Double);
 
 begin
@@ -1881,15 +1914,15 @@ end;
 
 procedure TFloatField.SetAsString(const AValue: string);
 
-var R : Double;
+var f : Double;
 
 begin
   If (AValue='') then
     Clear
   else  
     try
-      R := StrToFloat(AValue);
-      SetAsFloat(R);
+      f := StrToFloat(AValue);
+      SetAsFloat(f);
     except
       DatabaseErrorFmt(SNotAFloat, [AValue]);
     end;
@@ -1904,7 +1937,7 @@ constructor TFloatField.Create(AOwner: TComponent);
 
 begin
   Inherited Create(AOwner);
-  SetDatatype(ftFloat);
+  SetDataType(ftFloat);
   FPrecision:=15;
   FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
 end;
@@ -2457,8 +2490,8 @@ end;
 function TBCDField.GetDefaultWidth: Longint;
 
 begin
-  if precision > 0 then result := precision
-    else result := 10;
+  if Precision > 0 then Result := Precision+1
+  else Result := 10;
 end;
 
 procedure TBCDField.GetText(var TheText: string; ADisplayText: Boolean);
@@ -2546,8 +2579,8 @@ begin
   FMinValue := 0;
   FValidChars := [DecimalSeparator, '+', '-', '0'..'9'];
   SetDataType(ftBCD);
-  FPrecision := 15;
-  Size:=4;
+  Precision := 18;
+  Size := 4;
 end;
 
 
@@ -2568,8 +2601,8 @@ begin
   SetDataType(ftFMTBCD);
 // Max.precision for NUMERIC,DECIMAL datatypes supported by some databases:
 //  Firebird-18; Oracle,SqlServer-38; MySQL-65; PostgreSQL-1000
-  Precision := 15; //default number of digits
-  Size:=4; //default number of digits after decimal place
+  Precision := 18; //default number of digits
+  Size := 4; //default number of digits after decimal place
 end;
 
 function TFMTBCDField.GetDataSize: Integer;
@@ -2749,7 +2782,7 @@ end;
 
 procedure TBlobField.SetBlobType(AValue: TBlobType);
 begin
-  SetFieldType(TFieldType(BlobType));
+  SetFieldType(TFieldType(AValue));
 end;
 
 procedure TBlobField.FreeBuffers;
@@ -2780,17 +2813,30 @@ function TBlobField.GetAsString: string;
 var
   Stream : TStream;
   Len    : Integer;
+  S : String;
+  
 begin
   Stream := GetBlobStream(bmRead);
   if Stream <> nil then
     with Stream do
       try
         Len := Size;
-        SetLength(Result, Len);
+        SetLength(S, Len);
         if Len > 0 then
-          ReadBuffer(Result[1], Len);
+          begin
+          ReadBuffer(S[1], Len);
+          if not Transliterate then
+            Result := S
+          else
+            begin
+            SetLength(Result, Len);
+            DataSet.Translate(@S[1],@Result[1],False);
+            end;
+          end
+        else
+          Result := '';
       finally
-        Free
+        Free;    
       end
   else
     Result := '';
@@ -2885,12 +2931,23 @@ end;
 procedure TBlobField.SetAsString(const AValue: string);
 var
   Len : Integer;
+  S : String;
+  
 begin
   with GetBlobStream(bmWrite) do
     try
       Len := Length(AValue);
-      if Len > 0 then
-        WriteBuffer(AValue[1], Len);
+      if (Len>0) then
+        begin
+        if Not Transliterate then
+          S:=AValue
+        else
+          begin
+          SetLength(S,Len);
+          Len:=DataSet.Translate(@AValue[1],@S[1],True);
+          end;  
+        WriteBuffer(S[1], Len);
+        end;
     finally
       Free;
     end;
@@ -2996,7 +3053,7 @@ end;
 procedure TBlobField.SetFieldType(AValue: TFieldType);
 begin
   if AValue in ftBlobTypes then
-    SetDatatype(AValue);
+    SetDataType(AValue);
 end;
 
 { TMemoField }

packages/fcl-db/src/base/sqlscript.pp

@@ -260,7 +260,7 @@ begin
     if (Result='') then
       begin
       if FEmitLine then
-        AddToStatement(S,(FCol=1));
+        AddToStatement(S,(FCol<=1));
       FCol:=1;
       FLine:=FLine+1;
       end
@@ -442,11 +442,12 @@ function TCustomSQLScript.NextStatement: AnsiString;
 
 var
   pnt: AnsiString;
-  terminator_found: Boolean;
+  addnewline,terminator_found: Boolean;
 
 begin
   terminator_found:=False;
   ClearStatement;
+  addnewline:=false;
   while FLine <= FSQL.Count do
     begin
     pnt:=FindNextSeparator([FTerminator, '/*', '"', '''', '--']);
@@ -476,7 +477,10 @@ begin
       begin
       FComment:=True;
       if FCommentsInSQL then
-        AddToStatement(Copy(FSQL[FLine-1],FCol,Length(FSQL[FLine-1])-FCol+1),True);
+        begin
+        AddToStatement(Copy(FSQL[FLine-1],FCol,Length(FSQL[FLine-1])-FCol+1),False);
+        AddNewLine:=true;
+        end;
       Inc(Fline);
       FCol:=0;
       FComment:=False;
@@ -494,7 +498,8 @@ begin
       AddToStatement(pnt,False);
       FCol:=FCol + length(pnt);
       pnt:=FindNextSeparator(['''']);
-      AddToStatement(pnt,false);
+      AddToStatement(pnt,addnewline);
+      addnewline:=False;
       FCol:=FCol + length(pnt);
       end;
     end;

packages/fcl-db/src/datadict/fpdatadict.pp

@@ -1647,6 +1647,7 @@ end;
 
 destructor TFPDataDictionary.Destroy;
 begin
+  FreeAndNil(FDomains);
   FreeAndNil(FSequences);
   FreeAndNil(FTables);
   inherited Destroy;

packages/fcl-db/src/dbase/dbf_str.pas

@@ -11,7 +11,7 @@ initialization
 
   STRING_FILE_NOT_FOUND               := 'Open: file not found: "%s".';
   STRING_VERSION                      := 'TDbf V%d.%d';
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL:= 'This feature is not supported in tablelevel %d';
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'This feature is not supported in tablelevel %d';
 
   STRING_RECORD_LOCKED                := 'Record locked.';
   STRING_WRITE_ERROR                  := 'Error while writing occurred. (Disk full?)';

packages/fcl-db/src/dbase/dbf_str_es.pas

@@ -12,7 +12,7 @@ initialization
   STRING_FILE_NOT_FOUND               := 'Apertura: archivo no encontrado: "%s".';
   STRING_VERSION                      := 'TDbf V%d.%d';
   // todo: translate me
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'This feature is not supported in tablelevel %d';
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'This feature is not supported in tablelevel %d';
 
   STRING_RECORD_LOCKED                := 'Registro bloqueado.';
   STRING_WRITE_ERROR                  := 'Error de escritura. (Disco lleno?)';

packages/fcl-db/src/dbase/dbf_str_fr.pas

@@ -11,7 +11,7 @@ initialization
 
   STRING_FILE_NOT_FOUND               := 'Ouverture: fichier non trouvé: "%s"';
   STRING_VERSION                      := 'TDbf V%d.%d';
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'Cette fonctionnalité n'est pas supporté dans tablelevel %d'; 
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'Cette fonctionnalité n''est pas supporté dans tablelevel %d';
   
   STRING_RECORD_LOCKED                := 'Enregistrement verrouillé.';
   STRING_KEY_VIOLATION                := 'Violation de clé. (doublon dans un index).'+#13+#10+

packages/fcl-db/src/dbase/dbf_str_ita.pas

@@ -13,7 +13,7 @@ initialization
   STRING_FILE_NOT_FOUND               := 'Apertura: file non trovato: "%s"';
   STRING_VERSION                      := 'TDbf V%d.%d';
   // todo: translate me
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'This feature is not supported in tablelevel %d'; 
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'This feature is not supported in tablelevel %d'; 
 
   STRING_RECORD_LOCKED                := 'Record già in uso.';
 

packages/fcl-db/src/dbase/dbf_str_nl.pas

@@ -11,7 +11,7 @@ initialization
 
   STRING_FILE_NOT_FOUND               := 'Openen: bestand niet gevonden: "%s"';
   STRING_VERSION                      := 'TDbf V%d.%d';
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'Deze functionaliteit wordt niet ondersteund in tablelevel %d'; 
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'Deze functionaliteit wordt niet ondersteund in tablelevel %d';
 
   STRING_RECORD_LOCKED                := 'Record in gebruik.';
   STRING_WRITE_ERROR                  := 'Error tijdens schrijven. (Disk vol?)';

packages/fcl-db/src/dbase/dbf_str_pl.pas

@@ -9,31 +9,30 @@ implementation
 
 initialization
 
-  STRING_FILE_NOT_FOUND               := 'Open: brak pliku: "%s"';
+  STRING_FILE_NOT_FOUND               := 'Otwórz: brak pliku: "%s".';
   STRING_VERSION                      := 'TDbf V%d.%d';
-  // todo: translate me
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'This feature is not supported in tablelevel %d';
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'Ta funkcja nie jest obs³ugiwana w typie bazy (tablelevel) %d';
 
   STRING_RECORD_LOCKED                := 'Rekord zablokowany.';
-  STRING_WRITE_ERROR                  := 'Niezapisano(Brak miejsca na dysku?)';
-  STRING_KEY_VIOLATION                := 'Konflikt klucza. (Klucz obecny w pliku).'+#13+#10+
-                                         'Indeks: %s'+#13+#10+'Rekord=%d Klucz=''%s''';
-
-  STRING_INVALID_DBF_FILE             := 'Uszkodzony plik bazy.';
-  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Uszkodzony plik bazy. Uszkodzony pol.'; //todo: definitely check field part
-  STRING_FIELD_TOO_LONG               := 'Dana za d³uga : %d znaków (dopuszczalne do %d).';
-  STRING_INVALID_FIELD_COUNT          := 'Z³a liczba pól: %d (dozwolone 1 do 4095).';
-  STRING_INVALID_FIELD_TYPE           := 'B³êdny typ pola ''%c'' dla pola ''%s''.';
-  STRING_INVALID_VCL_FIELD_TYPE       := 'Nie mogê tworzyæ pola "%s", typ pola VCL %x nie wspierany przez DBF.';
-
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Kluczowe pole indeksu "%s" nie istnieje';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Typ pola "%s" niedozwolony dla indeksów';
-  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Zbyt d³ugi wynik "%s", >100 znaków (%d).';
-  STRING_INVALID_INDEX_TYPE           := 'Z³y typ indeksu: tylko string lub float';
-  STRING_CANNOT_OPEN_INDEX            := 'Nie mogê otworzyæ indeksu: "%s"';
-  STRING_TOO_MANY_INDEXES             := 'Nie mogê stworzyæ indeksu: za du¿o w pliku.';
-  STRING_INDEX_NOT_EXIST              := 'Brak indeksu "%s".';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'Operacja wymaga dostêpu w trybie Exclusive.';
+  STRING_WRITE_ERROR                  := 'Wyst¹pi³ b³¹d podczas zapisu. (Brak miejsca na dysku?)';
+  STRING_KEY_VIOLATION                := 'Konflikt klucza. (Klucz jest obecny w pliku).'+#13+#10+
+                                         'Indeks: %s'+#13+#10+'Rekord=%d Klucz=''%s''.';
+
+  STRING_INVALID_DBF_FILE             := 'Nieprawid³owy plik DBF.';
+  STRING_INVALID_DBF_FILE_FIELDERROR  := 'Nieprawid³owy plik DBF. B³êdna definicja pola.'; 
+  STRING_FIELD_TOO_LONG               := 'Wartoœæ jest za d³uga: %d znaków (maksymalnie %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Nieprawid³owa liczba pól: %d (dozwolone 1 do 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'Nieprawid³owy typ pola ''%s'' dla pola ''%s''.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Nie mo¿na utworzyæ pola "%s", typ pola VCL %x nie jest obs³ugiwany przez DBF.';
+
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Indeks bazuje na nieznanym polu "%s".';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Typ pola "%s" jest nieprawid³owy dla indeksów.';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Wynik indeksu dla "%s" jest za d³ugi, >100 znaków (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Nieprawid³owy typ indeksu: tylko string lub float.';
+  STRING_CANNOT_OPEN_INDEX            := 'Nie mogê otworzyæ indeksu: "%s".';
+  STRING_TOO_MANY_INDEXES             := 'Nie mogê utworzyæ indeksu: za du¿o indeksów w pliku.';
+  STRING_INDEX_NOT_EXIST              := 'Indeks "%s" nie istnieje.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Wymagany jest wy³¹czny dostêp dla tej operacji.';
 end.
 

packages/fcl-db/src/dbase/dbf_str_pt.pas

@@ -14,7 +14,7 @@ initialization
   STRING_FILE_NOT_FOUND               := 'Abertura: arquivo não encontrado: "%s".';
   STRING_VERSION                      := 'TDbf V%d.%d';
   //todo: translate me
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'This feature is not supported in tablelevel %d';
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'This feature is not supported in tablelevel %d';
 
   STRING_RECORD_LOCKED                := 'Registro bloqueado.';
   STRING_WRITE_ERROR                  := 'Erro de escrita. (Disco cheio?)';

packages/fcl-db/src/dbase/dbf_str_ru.pas

@@ -17,7 +17,7 @@ initialization
   STRING_FILE_NOT_FOUND               := 'Ôàéë "%s" íå ñóùåñòâóåò. Îòêðûòü íåâîçìîæíî.';
   STRING_VERSION                      := 'TDbf V%d.%d';
   //todo: translate me
-  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL: string; := 'This feature is not supported in tablelevel %d';
+  STRING_FEATURE_NOT_SUPPORTED_THIS_TABLELEVEL := 'This feature is not supported in tablelevel %d';
 
   STRING_RECORD_LOCKED                := 'Çàïèñü (ñòðîêà òàáëèöû) çàáëîêèðîâàíà.';
   STRING_WRITE_ERROR                  := 'Îøèáêà çàïèñè íà äèñê (Äèñê çàïîëíåí?)';

packages/fcl-db/src/export/fpcsvexport.pp

@@ -5,7 +5,7 @@ unit fpcsvexport;
 interface
 
 uses
-  Classes, SysUtils, DB, fpDBExport;
+  Classes, SysUtils, fpDBExport, csvreadwrite;
 
 Type
   { TCSVFormatSettings }
@@ -14,35 +14,40 @@ Type
   Private
     FDelimiter: String;
     FHeaderRow: Boolean;
-    FQuoteStrings: TQuoteStrings;
+    FIgnoreOuterWhiteSpace: Boolean;
     FRowDelimiter: String;
-    FStringQuoteChar: String;
+    FQuoteChar: Char;
   Public
     Constructor Create(DoInitSettings : Boolean); override;
     Procedure Assign(Source : TPersistent); override;
+    // Kept for compatibility with older versions; please replace with QuoteChar
+    Property StringQuoteChar : Char Read FQuoteChar Write FQuoteChar; deprecated 'Please replace with QuoteChar';
   Published
     // Properties
+    // Delimiter between fields/columns. Traditionally , for CSV.
     Property FieldDelimiter : String Read FDelimiter Write FDelimiter;
+    //If no, CSV is RFC 4180 compliant; if yes, it matches the unofficial Creativyst specification
+    Property IgnoreOuterWhitespace : Boolean Read FIgnoreOuterWhiteSpace write FIgnoreOuterWhiteSpace;
+    // Line ending to be used between rows of data (e.g. #13#10 for standard CSV)
     Property RowDelimiter : String Read FRowDelimiter Write FRowDelimiter;
+    // Whether or not the file should have a header row with field names
     Property HeaderRow : Boolean Read FHeaderRow Write FHeaderRow default true;
-    Property QuoteStrings : TQuoteStrings Read FQuoteStrings Write FQuoteStrings;
-    Property StringQuoteChar : String Read FStringQuoteChar Write FStringQuoteChar;
+    // If fields need to be surrounded by quotes, use this character (e.g. ")
+    Property QuoteChar : Char Read FQuoteChar Write FQuoteChar;
   end;
 
   { TCustomCSVExporter }
 
   TCustomCSVExporter = Class(TCustomFileExporter)
   private
-    FCurrentRow:String;
+    FCSVOut: TCSVBuilder;
     function GetCSVFormatsettings: TCSVFormatSettings;
-    procedure OutputRow(const ARow: String);
     procedure SetCSVFormatSettings(const AValue: TCSVFormatSettings);
   Protected
     Function CreateFormatSettings : TCustomExportFormatSettings; override;
     Procedure DoBeforeExecute; override;
     Procedure DoAfterExecute; override;
     Procedure DoDataHeader; override;
-    Procedure DoDataRowStart; override;
     Procedure ExportField(EF : TExportFieldItem); override;
     Procedure DoDataRowEnd; override;
   Public
@@ -82,27 +87,23 @@ implementation
 procedure TCustomCSVExporter.DoBeforeExecute;
 begin
   inherited DoBeforeExecute;
+  FCSVOut:=TCSVBuilder.Create;
+  if (FormatSettings.FieldDelimiter<>'') then
+    FCSVOut.Delimiter:=FormatSettings.FieldDelimiter[1];
+  FCSVOut.IgnoreOuterWhitespace:=FormatSettings.IgnoreOuterWhitespace;
+  FCSVOut.LineEnding:=FormatSettings.RowDelimiter;
+  FCSVOut.QuoteChar:=FormatSettings.QuoteChar;
   OpenTextFile;
+  FCSVOut.SetOutput(Stream); //output to the export stream
 end;
 
 procedure TCustomCSVExporter.DoAfterExecute;
 begin
+  FCSVOut.Free;
   CloseTextFile;
   inherited DoAfterExecute;
 end;
 
-procedure TCustomCSVExporter.OutputRow(Const ARow : String);
-
-Var
-  RD : String;
-
-begin
-  RD:=FormatSettings.RowDelimiter;
-  If (RD='') then
-    Writeln(TextFile,ARow)
-  else
-    Write(TextFile,ARow,RD)
-end;
 
 function TCustomCSVExporter.GetCSVFormatsettings: TCSVFormatSettings;
 begin
@@ -124,84 +125,29 @@ end;
 procedure TCustomCSVExporter.DoDataHeader;
 
 Var
-  S : String;
   I : Integer;
 
 begin
   If FormatSettings.HeaderRow then
     begin
-    S:='';
     For I:=0 to ExportFields.Count-1 do
       begin
-      If (S<>'') then
-        S:=S+FormatSettings.FieldDelimiter;
-      S:=S+ExportFields[i].ExportedName;
+      FCSVOut.AppendCell(ExportFields[i].ExportedName);
       end;
-    OutputRow(S);
+    FCSVOut.AppendRow; //close off with line ending
     end;
   inherited DoDataHeader;
 end;
 
 
-procedure TCustomCSVExporter.DoDataRowStart;
-begin
-  FCurrentRow:='';
-end;
-
 procedure TCustomCSVExporter.ExportField(EF: TExportFieldItem);
-
-  Function HaveSpace(Const S : String;QS : TQuoteStrings) : Boolean;
-
-  begin
-    Result:=(qsSpace in QS) and (Pos(' ',S)<>0)
-  end;
-
-  Function HaveDelimiter(Const S : String;QS : TQuoteStrings) : Boolean;
-
-  Var
-    FD : String;
-
-  begin
-    Result:=(qsDelimiter in QS);
-    If Result then
-      begin
-      FD:=FormatSettings.FieldDelimiter;
-      Result:=(FD<>'') and (Pos(FD,S)<>0);
-      end;
-  end;
-
-Var
-  S,C : String;
-  QS  : TQuoteStrings;
-
 begin
-  S:=FormatField(EF.Field);
-  QS:=FormatSettings.QuoteStrings;
-  {If specified, quote everything that can contain delimiters;
-  leave numeric, date fields alone:}
-  If (
-  (EF.Field.DataType in StringFieldTypes) or
-  (EF.Field.DataType in MemoFieldTypes) or
-  (EF.Field.DataType in BlobFieldTypes)
-  )
-  and (QS<>[]) then
-    begin
-    If (qsAlways in QS) or HaveSpace(S,QS) or HaveDelimiter(S,QS) then
-      begin
-      C:=FormatSettings.StringQuoteChar;
-      S:=C+S+C;
-      end;
-    end;
-  If (FCurrentRow<>'') then
-    FCurrentRow:=FCurrentRow+FormatSettings.FieldDelimiter;
-  FCurrentRow:=FCurrentRow+S;
+  FCSVOut.AppendCell(FormatField(EF.Field));
 end;
 
-
 procedure TCustomCSVExporter.DoDataRowEnd;
 begin
-  OutputRow(FCurrentRow);
-  FCurrentRow:='';
+  FCSVOut.AppendRow; //Line ending
 end;
 
 constructor TCustomCSVExporter.Create(Aowner: TComponent);
@@ -213,14 +159,12 @@ end;
 
 constructor TCSVFormatSettings.Create(DoInitSettings: Boolean);
 begin
+  // These defaults are meant to be Excel CSV compatible
   inherited Create(DoInitSettings);
   FHeaderRow:=True;
   FDelimiter:=',';
-  FStringQuoteChar:='"';
-  FQuoteStrings:=[qsSpace, qsDelimiter];
-  {Sensible defaults as reading unquoted strings with delimiters/spaces will
-  either fail by creating phantom fields (qsDelimiter) or delete leading or
-  trailing data/spaces (qsSpace)}
+  FQuoteChar:='"';
+  FRowDelimiter:=LineEnding;
 end;
 
 procedure TCSVFormatSettings.Assign(Source: TPersistent);
@@ -233,10 +177,9 @@ begin
     begin
     FS:=Source as TCSVFormatSettings;
     FDelimiter:=FS.FDelimiter;
-    FHeaderRow:=FS.FHEaderRow;
-    FQuoteStrings:=FS.FQuoteStrings;
+    FHeaderRow:=FS.FHeaderRow;
     FRowDelimiter:=FS.FRowDelimiter;
-    FStringQuoteChar:=FS.FStringQuoteChar;
+    FQuoteChar:=FS.FQuoteChar;
     end;
   inherited Assign(Source);
 end;
@@ -250,8 +193,8 @@ end;
 Procedure UnRegisterCSVExportFormat;
 
 begin
+  ExportFormats.UnRegisterExportFormat(SCSVExport);
 end;
 
 
 end.
-

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

@@ -46,29 +46,31 @@ type
 
   MDSError=class(Exception);
 
-  PRecInfo=^TMTRecInfo;
-  TMTRecInfo=record
-    Bookmark: Longint;
-    BookmarkFlag: TBookmarkFlag;
-  end;
-
   { TMemDataset }
 
   TMemDataset=class(TDataSet)
   private
-    FOpenStream : TStream;
-    FFileName : String;
-    FFileModified : Boolean;
-    FStream: TMemoryStream;
-    FRecInfoOffset: integer;
-    FRecCount: integer;
-    FRecSize: integer;
-    FCurrRecNo: integer;
-    FIsOpen: boolean;
-    FTableIsCreated: boolean;
-    FFilterBuffer: TRecordBuffer;
-    ffieldoffsets: PInteger;
-    ffieldsizes: PInteger;
+    type
+      TMDSBlobList = class(TFPList)
+        public
+          procedure Clear; reintroduce;
+      end;
+    var
+      FOpenStream : TStream;
+      FFileName : String;
+      FFileModified : Boolean;
+      FStream: TMemoryStream;
+      FRecInfoOffset: integer;
+      FRecCount: integer;
+      FRecSize: integer;
+      FCurrRecNo: integer;
+      FIsOpen: boolean;
+      FTableIsCreated: boolean;
+      FFilterBuffer: TRecordBuffer;
+      ffieldoffsets: PInteger;
+      ffieldsizes: PInteger;
+      FBlobs: TMDSBlobList;
+
     function GetRecordBufferPointer(p:TRecordBuffer; Pos:Integer):TRecordBuffer;
     function GetIntegerPointer(p:PInteger; Pos:Integer):PInteger;
 
@@ -126,17 +128,16 @@ type
     // If SaveData=False, a size 0 block should be written.
     Procedure SaveDataToStream(F : TStream; SaveData : Boolean); virtual;
 
-
   public
-    constructor Create(AOwner:tComponent); override;
+    constructor Create(AOwner:TComponent); override;
     destructor Destroy; override;
     function BookmarkValid(ABookmark: TBookmark): Boolean; override;
+    function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
     function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): boolean; override;
     function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override;
-    procedure CreateTable;
 
+    procedure CreateTable;
     Function  DataSize : Integer;
-
     Procedure Clear(ClearDefs : Boolean);{$IFNDEF FPC} overload; {$ENDIF}
     Procedure Clear;{$IFNDEF FPC} overload; {$ENDIF}
     Procedure SaveToFile(AFileName : String);{$IFNDEF FPC} overload; {$ENDIF}
@@ -183,7 +184,7 @@ type
 implementation
 
 uses
-  Variants, FmtBCD;
+  DBConst, Variants, FmtBCD;
 
 ResourceString
   SErrFieldTypeNotSupported = 'Fieldtype of Field "%s" not supported.';
@@ -192,8 +193,40 @@ ResourceString
   SErrInvalidMarkerAtPos    = 'Wrong data stream marker at position %d. Got %d, expected %d';
   SErrNoFileName            = 'Filename must not be empty.';
 
+type
+  TMDSRecInfo=record
+    Bookmark: Longint;
+    BookmarkFlag: TBookmarkFlag;
+  end;
+  PRecInfo=^TMDSRecInfo;
+
+  TMDSBlobField = record
+    Buffer: Pointer;  // pointer to memory allocated for Blob data
+    Size: PtrInt;     // size of Blob data
+  end;
+
+  { TMDSBlobStream }
+
+  TMDSBlobStream = class(TStream)
+    private
+      FField      : TBlobField;
+      FDataSet    : TMemDataset;
+      FBlobField  : TMDSBlobField;
+      FPosition   : PtrInt;
+      FModified   : boolean;
+      procedure AllocBlobField(NewSize: PtrInt);
+      procedure FreeBlobField;
+    public
+      constructor Create(Field: TField; Mode: TBlobStreamMode);
+      destructor Destroy; override;
+      function Seek(const Offset: int64; Origin: TSeekOrigin): int64; override;
+      function Read(var Buffer; Count: Longint): Longint; override;
+      function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
 Const
-  SizeRecInfo = SizeOf(TMTRecInfo);
+  SizeRecInfo = SizeOf(TMDSRecInfo);
+
 
 procedure unsetfieldisnull(nullmask: pbyte; const x: integer);
 
@@ -259,22 +292,110 @@ begin
     S.WriteBuffer(Value[1],L);
 end;
 
+
+{ TMDSBlobStream }
+
+constructor TMDSBlobStream.Create(Field: TField; Mode: TBlobStreamMode);
+begin
+  FField := Field as TBlobField;
+  FDataSet := Field.DataSet as TMemDataset;
+  if not Field.GetData(@FBlobField) then // IsNull
+  begin
+    FBlobField.Buffer := nil;
+    FBlobField.Size := 0;
+  end;
+
+  if Mode = bmWrite then
+    // release existing Blob
+    FreeBlobField;
+end;
+
+destructor TMDSBlobStream.Destroy;
+begin
+  if FModified then
+  begin
+    if FBlobField.Size = 0 then // Empty blob = IsNull
+      FField.SetData(nil)
+    else
+      FField.SetData(@FBlobField);
+  end;
+  inherited;
+end;
+
+procedure TMDSBlobStream.FreeBlobField;
+begin
+  FDataSet.FBlobs.Remove(FBlobField.Buffer);
+  FreeMem(FBlobField.Buffer, FBlobField.Size);
+  FBlobField.Buffer := nil;
+  FBlobField.Size := 0;
+  FModified := True;
+end;
+
+procedure TMDSBlobStream.AllocBlobField(NewSize: PtrInt);
+begin
+  FDataSet.FBlobs.Remove(FBlobField.Buffer);
+  ReAllocMem(FBlobField.Buffer, NewSize);
+  FDataSet.FBlobs.Add(FBlobField.Buffer);
+  FModified := True;
+end;
+
+function TMDSBlobStream.Seek(const Offset: int64; Origin: TSeekOrigin): int64;
+begin
+  Case Origin of
+    soBeginning : FPosition := Offset;
+    soEnd       : FPosition := FBlobField.Size + Offset;
+    soCurrent   : FPosition := FPosition + Offset;
+  end;
+  Result := FPosition;
+end;
+
+function TMDSBlobStream.Read(var Buffer; Count: Longint): Longint;
+var p: Pointer;
+begin
+  if FPosition + Count > FBlobField.Size then
+    Count := FBlobField.Size - FPosition;
+  p := FBlobField.Buffer + FPosition;
+  Move(p^, Buffer, Count);
+  Inc(FPosition, Count);
+  Result := Count;
+end;
+
+function TMDSBlobStream.Write(const Buffer; Count: Longint): Longint;
+var p: Pointer;
+begin
+  AllocBlobField(FPosition+Count);
+  p := FBlobField.Buffer + FPosition;
+  Move(Buffer, p^, Count);
+  Inc(FBlobField.Size, Count);
+  Inc(FPosition, Count);
+  Result := Count;
+end;
+
+
+{ TMemDataset.TMDSBlobList }
+
+procedure TMemDataset.TMDSBlobList.Clear;
+var i: integer;
+begin
+  for i:=0 to Count-1 do FreeMem(Items[i]);
+  inherited Clear;
+end;
+
 { ---------------------------------------------------------------------
     TMemDataset
   ---------------------------------------------------------------------}
 
-
-constructor TMemDataset.Create(AOwner:tComponent);
+constructor TMemDataset.Create(AOwner:TComponent);
 
 begin
-  inherited create(aOwner);
+  inherited Create(AOwner);
   FStream:=TMemoryStream.Create;
   FRecCount:=0;
   FRecSize:=0;
   FRecInfoOffset:=0;
   FCurrRecNo:=-1;
   BookmarkSize := sizeof(Longint);
-  FIsOpen:=False;
+  FBlobs := TMDSBlobList.Create;
 end;
 
 destructor TMemDataset.Destroy;
@@ -282,6 +403,8 @@ begin
   FStream.Free;
   FreeMem(FFieldOffsets);
   FreeMem(FFieldSizes);
+  FBlobs.Clear;
+  FBlobs.Free;
   inherited Destroy;
 end;
 
@@ -295,6 +418,20 @@ begin
   Result := (ReqBookmark>=0) and (ReqBookmark<FRecCount);
 end;
 
+function TMemDataset.CreateBlobStream(Field: TField; Mode: TBlobStreamMode
+  ): TStream;
+begin
+  // Blobs are not saved to stream/file !
+  if Mode = bmWrite then
+    begin
+    if not (State in [dsEdit, dsInsert, dsFilter, dsCalcFields]) then
+      DatabaseErrorFmt(SNotEditing, [Name], Self);
+    if Field.ReadOnly and not (State in [dsSetKey, dsFilter]) then
+      DatabaseErrorFmt(SReadOnlyField, [Field.DisplayName]);
+    end;
+  Result := TMDSBlobStream.Create(Field, Mode);
+end;
+
 function TMemDataset.MDSGetRecordOffset(ARecNo: integer): longint;
 begin
   Result:=FRecSize*ARecNo
@@ -302,7 +439,7 @@ end;
 
 function TMemDataset.MDSGetFieldOffset(FieldNo: integer): integer;
 begin
- result:= getIntegerpointer(ffieldoffsets, fieldno-1)^;
+  Result:= getIntegerPointer(ffieldoffsets, fieldno-1)^;
 end;
 
 procedure TMemDataset.RaiseError(Fmt: String; Args: array of const);
@@ -333,10 +470,12 @@ begin
     ftTime,
     ftDate:   result:=SizeOf(TDateTime);
   ftFmtBCD:   result:=SizeOf(TBCD);
-  ftWideString,
-  ftFixedWideChar: result:=(FD.Size+1)*SizeOf(WideChar);
+  ftWideString, ftFixedWideChar:
+              result:=(FD.Size+1)*SizeOf(WideChar);
   ftBytes:    result := FD.Size;
   ftVarBytes: result := FD.Size + SizeOf(Word);
+  ftBlob, ftMemo, ftWideMemo:
+              result := SizeOf(TMDSBlobField);
  else
   RaiseError(SErrFieldTypeNotSupported,[FD.Name]);
  end;
@@ -346,26 +485,22 @@ begin
 end;
 
 function TMemDataset.MDSGetActiveBuffer(out Buffer: TRecordBuffer): Boolean;
-
 begin
- case State of
-   dsBrowse,
-   dsBlockRead:
-     if IsEmpty then
-       Buffer:=nil
-     else
-       Buffer:=ActiveBuffer;
-  dsEdit,
-  dsInsert:
-     Buffer:=ActiveBuffer;
-  dsFilter:
-     Buffer:=FFilterBuffer;
-  dsCalcFields:
-     Buffer:=CalcBuffer;
- else
-   Buffer:=nil;
- end;
- Result:=(Buffer<>nil);
+  case State of
+    dsEdit,
+    dsInsert:
+      Buffer:=ActiveBuffer;
+    dsFilter:
+      Buffer:=FFilterBuffer;
+    dsCalcFields:
+      Buffer:=CalcBuffer;
+    else
+      if IsEmpty then
+        Buffer:=nil
+      else
+        Buffer:=ActiveBuffer;
+  end;
+  Result := Buffer<>nil;
 end;
 
 procedure TMemDataset.MDSReadRecord(Buffer:TRecordBuffer;ARecNo:Integer);   //Reads a Rec from Stream in Buffer
@@ -537,6 +672,7 @@ Var
 begin
   CheckMarker(F,smData);
   Size:=ReadInteger(F);
+  FBlobs.Clear;
   FStream.Clear;
   FStream.CopyFrom(F,Size);
   FRecCount:=Size div FRecSize;
@@ -658,9 +794,8 @@ begin
  FIsOpen:=False;
  FFileModified:=False;
  // BindFields(False);
- if DefaultFields then begin
+ if DefaultFields then
   DestroyFields;
- end;
 end;
 
 procedure TMemDataset.InternalPost;
@@ -876,6 +1011,7 @@ end;
 procedure TMemDataset.Clear(ClearDefs : Boolean);
 
 begin
+  FBlobs.Clear;
   FStream.Clear;
   FRecCount:=0;
   FCurrRecNo:=-1;
@@ -911,7 +1047,7 @@ begin
  for i:= 0 to Count-1 do
    begin
    GetIntegerPointer(FFieldOffsets, i)^ := FRecSize;
-   GetIntegerPointer(FFieldSizes,   i)^ := MDSGetbufferSize(i+1);
+   GetIntegerPointer(FFieldSizes,   i)^ := MDSGetBufferSize(i+1);
    FRecSize:= FRecSize+GetIntegerPointer(FFieldSizes, i)^;
    end;
  FRecInfoOffset:=FRecSize;
@@ -922,10 +1058,7 @@ procedure TMemDataset.CreateTable;
 
 begin
   CheckInactive;
-  FStream.Clear;
-  FRecCount:=0;
-  FCurrRecNo:=-1;
-  FIsOpen:=False;
+  Clear(False);
   calcrecordlayout;
   FTableIsCreated:=True;
 end;

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

@@ -103,13 +103,14 @@ type
     function GetTransactionHandle(trans : TSQLHandle): pointer; override;
     function Commit(trans : TSQLHandle) : boolean; override;
     function RollBack(trans : TSQLHandle) : boolean; override;
-    function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
+    function StartDBTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
     procedure CommitRetaining(trans : TSQLHandle); override;
     procedure RollBackRetaining(trans : TSQLHandle); override;
     procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override;
-    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
     procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
     function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
+    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
+    function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; override;
   public
     constructor Create(AOwner : TComponent); override;
     function GetConnectionInfo(InfoType:TConnInfoType): string; override;
@@ -179,7 +180,7 @@ constructor TIBConnection.Create(AOwner : TComponent);
 
 begin
   inherited;
-  FConnOptions := FConnOptions + [sqSupportParams] + [sqEscapeRepeat];
+  FConnOptions := FConnOptions + [sqSupportParams, sqEscapeRepeat, sqSupportReturning];
   FBlobSegmentSize := 65535; //Shows we're using the maximum segment size
   FDialect := INVALID_DATA;
   ResetDatabaseInfo;
@@ -208,7 +209,8 @@ begin
   else result := true;
 end;
 
-function TIBConnection.StartDBTransaction(trans : TSQLHandle;AParams : String) : boolean;
+function TIBConnection.StartDBTransaction(trans: TSQLHandle; AParams: string
+  ): boolean;
 var
   DBHandle : pointer;
   tr       : TIBTrans;
@@ -641,7 +643,7 @@ begin
   end;
 end;
 
-Function TIBConnection.AllocateCursorHandle : TSQLCursor;
+function TIBConnection.AllocateCursorHandle: TSQLCursor;
 
 var curs : TIBCursor;
 
@@ -665,7 +667,7 @@ begin
   FreeAndNil(cursor);
 end;
 
-Function TIBConnection.AllocateTransactionHandle : TSQLHandle;
+function TIBConnection.AllocateTransactionHandle: TSQLHandle;
 
 begin
   result := TIBTrans.create;
@@ -729,7 +731,7 @@ begin
     BlockSize:=isc_vax_integer(@resbuf[1],2);
     IBStatementType:=isc_vax_integer(@resbuf[3],blockSize);
     assert(resbuf[3+blockSize]=isc_info_end);
-    // If the statementtype is isc_info_sql_stmt_exec_procedure then
+    // If the StatementType is isc_info_sql_stmt_exec_procedure then
     // override the statement type derived by parsing the query.
     // This to recognize statements like 'insert into .. returning' correctly
     case IBStatementType of
@@ -751,6 +753,7 @@ begin
         if isc_dsql_describe(@Status[0], @Statement, 1, SQLDA) <> 0 then
           CheckError('PrepareSelect', Status);
         end;
+      FSelectable := SQLDA^.SQLD > 0;
       {$push}
       {$R-}
       for x := 0 to SQLDA^.SQLD - 1 do with SQLDA^.SQLVar[x] do
@@ -1388,12 +1391,27 @@ begin
                           '(r.rdb$system_flag = 0 or r.rdb$system_flag is null) and (rdb$relation_name = ''' + Uppercase(SchemaObjectName) + ''') ' +
                         'ORDER BY '+
                           'r.rdb$field_name';
+    stSequences  : s := 'SELECT ' +
+                          'rdb$generator_id         as recno,' +
+                          '''' + DatabaseName + ''' as sequence_catalog,' +
+                          '''''                     as sequence_schema,' +
+                          'rdb$generator_name       as sequence_name ' +
+                        'FROM ' +
+                          'rdb$generators ' +
+                        'WHERE ' +
+                          'rdb$system_flag = 0 or rdb$system_flag is null ' +
+                        'ORDER BY ' +
+                          'rdb$generator_name';
   else
     DatabaseError(SMetadataUnavailable)
   end; {case}
   result := s;
 end;
 
+function TIBConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string;
+begin
+  Result := Format('SELECT gen_id(%s, %d) FROM RDB$DATABASE', [SequenceName, IncrementBy]);
+end;
 
 procedure TIBConnection.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string);
 
@@ -1480,7 +1498,7 @@ begin
   end;
 end;
 
-procedure TIBConnection.GetFloat(CurrBuff, Buffer : pointer; Size : byte);
+procedure TIBConnection.GetFloat(CurrBuff, Buffer: pointer; Size: Byte);
 var
   Ext : extended;
   Dbl : double;

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

@@ -725,11 +725,16 @@ begin
       ftString, ftFixedChar:
         begin
         FieldSize := col.MaxLength;
-        if FieldSize > dsMaxStringSize then FieldSize := dsMaxStringSize;
+        if FieldSize >= $3FFFFFFF then // varchar(max)
+           FieldType := ftMemo;
+
         end;
-      ftMemo, ftBlob,
       ftBytes, ftVarBytes:
+        begin
         FieldSize := col.MaxLength;
+        if FieldSize >= $3FFFFFFF then // varbinary(max)
+           FieldType := ftBlob;
+        end;
       ftBCD:
         begin
         FieldSize := col.Scale;
@@ -738,10 +743,10 @@ begin
         end;
       ftGuid:
         FieldSize := 38;
-    else
-      FieldSize := 0;
-      if col.Identity and (FieldType = ftInteger) then
-        FieldType := ftAutoInc;
+      else
+        FieldSize := 0;
+        if col.Identity and (FieldType = ftInteger) then
+          FieldType := ftAutoInc;
     end;
 
     with FieldDefs.Add(FieldDefs.MakeNameUnique(FieldName), FieldType, FieldSize, (col.Null=0) and (not col.Identity), i) do
@@ -786,7 +791,7 @@ begin
   srctype:=dbcoltype(FDBProc,i);
   data:=dbdata(FDBProc,i);
   datalen:=dbdatlen(FDBProc,i);
-  Result:=assigned(data) and (datalen<>0);
+  Result:=assigned(data) and (datalen>=0);
   if not Result then
     Exit;
 

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

@@ -214,8 +214,8 @@ implementation
 
 uses
   dbconst,
-  strutils,
-  dateutils,
+  StrUtils,
+  DateUtils,
   FmtBCD;
 
 const
@@ -838,7 +838,7 @@ begin
     Result := StrToInt(S);
 end;
 
-function InternalStrToFloat(S: string): Extended;
+function InternalStrToFloat(const S: string): Extended;
 
 var
   I: Integer;
@@ -856,7 +856,7 @@ begin
   Result := StrToFloat(Tmp);
 end;
 
-function InternalStrToCurrency(S: string): Extended;
+function InternalStrToCurrency(const S: string): Currency;
 
 var
   I: Integer;
@@ -874,7 +874,7 @@ begin
   Result := StrToCurr(Tmp);
 end;
 
-function InternalStrToDate(S: string): TDateTime;
+function InternalStrToDate(const S: string): TDateTime;
 
 var
   EY, EM, ED: Word;
@@ -889,11 +889,30 @@ begin
     Result:=EncodeDate(EY, EM, ED);
 end;
 
-function InternalStrToDateTime(S: string): TDateTime;
+function StrToMSecs(const S: string): Word;
+var C: char;
+    d, MSecs: double;
+begin
+{$IFDEF MYSQL56_UP}
+  // datetime(n), where n is fractional seconds precision (between 0 and 6)
+  MSecs := 0;
+  d := 100;
+  for C in S do
+    begin
+    MSecs := MSecs + (ord(C)-ord('0'))*d;
+    d := d / 10;
+    end;
+  Result := Round(MSecs);
+{$ELSE}
+  Result := 0;
+{$ENDIF}
+end;
+
+function InternalStrToDateTime(const S: string): TDateTime;
 
 var
   EY, EM, ED: Word;
-  EH, EN, ES: Word;
+  EH, EN, ES, EMS: Word;
 
 begin
   EY := StrToInt(Copy(S, 1, 4));
@@ -902,17 +921,18 @@ begin
   EH := StrToInt(Copy(S, 12, 2));
   EN := StrToInt(Copy(S, 15, 2));
   ES := StrToInt(Copy(S, 18, 2));
+  EMS:= StrToMSecs(Copy(S, 21, 6));
   if (EY = 0) or (EM = 0) or (ED = 0) then
     Result := 0
   else
     Result := EncodeDate(EY, EM, ED);
-  Result := ComposeDateTime(Result,EncodeTime(EH, EN, ES, 0));
+  Result := ComposeDateTime(Result, EncodeTime(EH, EN, ES, EMS));
 end;
 
-function InternalStrToTime(S: string): TDateTime;
+function InternalStrToTime(const S: string): TDateTime;
 
 var
-  EH, EM, ES: Word;
+  EH, EM, ES, EMS: Word;
   p: integer;
 
 begin
@@ -920,14 +940,15 @@ begin
   EH := StrToInt(ExtractSubstr(S, p, [':'])); //hours can be 2 or 3 digits
   EM := StrToInt(ExtractSubstr(S, p, [':']));
   ES := StrToInt(ExtractSubstr(S, p, ['.']));
-  Result := EncodeTimeInterval(EH, EM, ES, 0);
+  EMS:= StrToMSecs(Copy(S, p, 6));
+  Result := EncodeTimeInterval(EH, EM, ES, EMS);
 end;
 
-function InternalStrToTimeStamp(S: string): TDateTime;
+function InternalStrToTimeStamp(const S: string): TDateTime;
 
 var
   EY, EM, ED: Word;
-  EH, EN, ES: Word;
+  EH, EN, ES, EMS: Word;
 
 begin
 {$IFNDEF mysql40}
@@ -937,6 +958,7 @@ begin
   EH := StrToInt(Copy(S, 12, 2));
   EN := StrToInt(Copy(S, 15, 2));
   ES := StrToInt(Copy(S, 18, 2));
+  EMS:= StrToMSecs(Copy(S, 21, 6));
 {$ELSE}
   EY := StrToInt(Copy(S, 1, 4));
   EM := StrToInt(Copy(S, 5, 2));
@@ -944,12 +966,13 @@ begin
   EH := StrToInt(Copy(S, 9, 2));
   EN := StrToInt(Copy(S, 11, 2));
   ES := StrToInt(Copy(S, 13, 2));
+  EMS:= 0;
 {$ENDIF}
   if (EY = 0) or (EM = 0) or (ED = 0) then
     Result := 0
   else
     Result := EncodeDate(EY, EM, ED);
-  Result := Result + EncodeTime(EH, EN, ES, 0);
+  Result := Result + EncodeTime(EH, EN, ES, EMS);
 end;
 
 function TConnectionName.MySQLWriteData(AField: PMYSQL_FIELD; FieldDef: TFieldDef; Source, Dest: PChar; Len: integer; out CreateBlob : boolean): Boolean;

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

@@ -56,10 +56,17 @@ type
 
   TODBCConnection = class(TSQLConnection)
   private
-    FDriver: string;
-    FEnvironment:TODBCEnvironment;
-    FDBCHandle:SQLHDBC; // ODBC Connection Handle
-    FFileDSN: string;
+    type
+      TDBMSInfo = record
+        GetLastInsertIDSQL: string; // SQL statement for get last insert value for autoincrement column
+      end;
+
+    var
+      FDriver: string;
+      FEnvironment:TODBCEnvironment;
+      FDBCHandle:SQLHDBC; // ODBC Connection Handle
+      FFileDSN: string;
+      FDBMSInfo: TDBMSInfo;
 
     procedure SetParameters(ODBCCursor:TODBCCursor; AParams:TParams);
     procedure FreeParamBuffers(ODBCCursor:TODBCCursor);
@@ -87,6 +94,7 @@ type
     // - Statement execution
     procedure Execute(cursor:TSQLCursor; ATransaction:TSQLTransaction; AParams:TParams); override;
     function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
+    function RefreshLastInsertID(Query : TCustomSQLQuery; Field : TField): boolean; override;
     // - Result retrieving
     procedure AddFieldDefs(cursor:TSQLCursor; FieldDefs:TFieldDefs); override;
     function Fetch(cursor:TSQLCursor):boolean; override;
@@ -305,6 +313,74 @@ begin
   end;
 end;
 
+(*
+function BCDToNumericStruct(const bcd: TBCD): SQL_NUMERIC_STRUCT;
+var i, j, p: integer;
+    nibble: Byte;
+    a, m, carry: DWord;
+    BigInt: array[0..3] of QWord;
+    qw: QWord;
+    pdw: PDWord;
+begin
+  Result.precision := BCDPrecision(bcd);
+  if Result.precision = 0 then Result.precision := 1; // if bcd is NULL
+  Result.scale := BCDScale(bcd);
+  if IsBCDNegative(bcd) then
+    Result.sign := 0
+  else
+    Result.sign := 1;
+  // BigInt := 0
+  FillByte(BigInt, sizeof(BigInt), 0);
+  // process BCD nibbles (high nibble is at 0)
+  p := Result.precision;
+  i := 0;
+  while p > 0 do
+  begin
+    nibble := bcd.Fraction[i];
+    if p = 1 then
+      begin
+      a := nibble shr 4;
+      m := 10;
+      end
+    else
+      begin
+      a := (nibble shr 4)*10 + nibble and $0F;
+      m := 100;
+      end;
+
+    // BigInt := BigInt * m + a
+    // big multiplication
+    j := 0; carry := 0;
+    repeat
+      qw := BigInt[j] * m + carry;
+      BigInt[j] := qw and $FFFFFFFF;
+      carry := qw shr 32;
+      inc(j);
+    until j>high(BigInt);
+
+    // big addition
+    j := 0; carry := 0;
+    repeat
+      qw := BigInt[j] + a + carry;
+      BigInt[j] := qw and $FFFFFFFF;
+      carry := qw shr 32;
+      inc(j);
+    until (carry = 0) or (j>high(BigInt));
+
+    dec(p,2);
+    inc(i);
+  end;
+
+  // SQL_NUMERIC_STRUCT.val size must be 16 bytes (128bit integer)
+  pdw := @Result.val;
+  for j:=0 to high(BigInt) do
+    begin
+    pdw^ := NtoLE(BigInt[j]);
+    inc(pdw);
+    end;
+end;
+*)
+
 procedure TODBCConnection.SetParameters(ODBCCursor: TODBCCursor; AParams: TParams);
 var
   ParamIndex: integer;
@@ -312,7 +388,7 @@ var
   I, Size: integer;
   IntVal: clong;
   LargeVal: clonglong;
-  StrVal: string;
+  StrVal: ansistring;
   WideStrVal: widestring;
   FloatVal: cdouble;
   DateVal: SQL_DATE_STRUCT;
@@ -439,6 +515,18 @@ begin
           ColumnSize:=NumericVal.precision;
           DecimalDigits:=NumericVal.scale;
         end;
+      ftFmtBCD:
+        begin
+          // bind FmtBCD parameter as string to support higher precision than 10^38 (supported by SQL_NUMERIC_STRUCT)
+          StrVal:=GetAsSQLText(AParams[ParamIndex]);
+          StrLenOrInd:=Length(StrVal);
+          PVal:=@StrVal[1];
+          Size:=Length(StrVal);
+          CType:=SQL_C_CHAR;
+          SqlType:=SQL_CHAR;
+          ColumnSize:=Size;
+          BufferLength:=Size;
+        end;
       ftDate:
         begin
           DateVal:=DateTimeToDateStruct(AParams[ParamIndex].AsDate);
@@ -465,6 +553,7 @@ begin
           CType:=SQL_C_TYPE_TIMESTAMP;
           SqlType:=SQL_TYPE_TIMESTAMP;
           ColumnSize:=23;
+          DecimalDigits:=3; // fractional seconds
         end;
       ftBoolean:
         begin
@@ -544,6 +633,7 @@ var
   ConnectionString:string;
   OutConnectionString:string;
   ActualLength:SQLSMALLINT;
+  DBMS_NAME: array[0..20] of AnsiChar;
 begin
   // Do not call the inherited method as it checks for a non-empty DatabaseName, and we don't even use DatabaseName!
   // inherited DoInternalConnect;
@@ -588,9 +678,24 @@ begin
     end;
   end;
 
-// commented out as the OutConnectionString is not used further at the moment
-//  if ActualLength<BufferLength-1 then
-//    SetLength(OutConnectionString,ActualLength); // fix completed connection string length
+  // set DBMS specific options
+  if SQLGetInfo(FDBCHandle, SQL_DBMS_NAME, @DBMS_NAME, sizeof(DBMS_NAME), @ActualLength) = SQL_SUCCESS then
+    case AnsiString(DBMS_NAME) of
+      'Microsoft SQL Server':
+        begin
+        FDBMSInfo.GetLastInsertIDSQL := 'SELECT @@IDENTITY';
+        Include(FConnOptions, sqLastInsertID);
+        end;
+      'MySQL':
+        begin
+        FDBMSInfo.GetLastInsertIDSQL := 'SELECT last_insert_id()';
+        Include(FConnOptions, sqLastInsertID);
+        end;
+      else
+        begin
+        FDBMSInfo.GetLastInsertIDSQL := '';
+        end;
+    end;
 
   // set connection attributes (none yet)
 end;
@@ -778,204 +883,20 @@ begin
     Result:=-1;
 end;
 
-function TODBCConnection.Fetch(cursor: TSQLCursor): boolean;
+function TODBCConnection.RefreshLastInsertID(Query : TCustomSQLQuery; Field : TField): boolean;
 var
-  ODBCCursor:TODBCCursor;
-  Res:SQLRETURN;
+  STMTHandle: SQLHSTMT;
+  StrLenOrInd: SQLLEN;
+  LastInsertID: LargeInt;
 begin
-  ODBCCursor:=cursor as TODBCCursor;
-
-  // fetch new row
-  Res:=SQLFetch(ODBCCursor.FSTMTHandle);
-  if Res<>SQL_NO_DATA then
-    ODBCCheckResult(Res,SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not fetch new row from result set.');
-
-  // result is true iff a new row was available
-  Result:=Res<>SQL_NO_DATA;
-end;
-
-const
-  DEFAULT_BLOB_BUFFER_SIZE = 1024;
-
-function TODBCConnection.LoadField(cursor: TSQLCursor; FieldDef: TFieldDef; buffer: pointer; out CreateBlob : boolean): boolean;
-var
-  ODBCCursor:TODBCCursor;
-  StrLenOrInd:SQLLEN;
-  ODBCDateStruct:SQL_DATE_STRUCT;
-  ODBCTimeStruct:SQL_TIME_STRUCT;
-  ODBCTimeStampStruct:SQL_TIMESTAMP_STRUCT;
-  DateTime:TDateTime;
-  Res:SQLRETURN;
-begin
-  CreateBlob := False;
-  ODBCCursor:=cursor as TODBCCursor;
-
-  // load the field using SQLGetData
-  // Note: optionally we can implement the use of SQLBindCol later for even more speed
-  // TODO: finish this
-  case FieldDef.DataType of
-    ftWideString,ftFixedWideChar: // mapped to TWideStringField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_WCHAR, buffer, FieldDef.Size+sizeof(WideChar), @StrLenOrInd); //buffer must contain space for the null-termination character
-    ftGuid, ftFixedChar,ftString: // are mapped to a TStringField (including TGuidField)
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_CHAR, buffer, FieldDef.Size+1, @StrLenOrInd);
-    ftSmallint:           // mapped to TSmallintField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SSHORT, buffer, SizeOf(Smallint), @StrLenOrInd);
-    ftInteger,ftAutoInc:  // mapped to TLongintField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SLONG, buffer, SizeOf(Longint), @StrLenOrInd);
-    ftWord:               // mapped to TWordField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_USHORT, buffer, SizeOf(Word), @StrLenOrInd);
-    ftLargeint:           // mapped to TLargeintField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SBIGINT, buffer, SizeOf(Largeint), @StrLenOrInd);
-    ftFloat,ftCurrency:   // mapped to TFloatField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_DOUBLE, buffer, SizeOf(Double), @StrLenOrInd);
-    ftTime:               // mapped to TTimeField
+  if SQLAllocHandle(SQL_HANDLE_STMT, FDBCHandle, STMTHandle) = SQL_SUCCESS then
     begin
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_TIME, @ODBCTimeStruct, SizeOf(SQL_TIME_STRUCT), @StrLenOrInd);
-      if StrLenOrInd<>SQL_NULL_DATA then
-      begin
-        DateTime:=TimeStructToDateTime(@ODBCTimeStruct);
-        Move(DateTime, buffer^, SizeOf(TDateTime));
-      end;
-    end;
-    ftDate:               // mapped to TDateField
-    begin
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_DATE, @ODBCDateStruct, SizeOf(SQL_DATE_STRUCT), @StrLenOrInd);
-      if StrLenOrInd<>SQL_NULL_DATA then
-      begin
-        DateTime:=DateStructToDateTime(@ODBCDateStruct);
-        Move(DateTime, buffer^, SizeOf(TDateTime));
-      end;
+    if SQLExecDirect(STMTHandle, PChar(FDBMSInfo.GetLastInsertIDSQL), Length(FDBMSInfo.GetLastInsertIDSQL)) = SQL_SUCCESS then
+      if SQLFetch(STMTHandle) = SQL_SUCCESS then
+        if SQLGetData(STMTHandle, 1, SQL_C_SBIGINT, @LastInsertID, SizeOf(LargeInt), @StrLenOrInd) = SQL_SUCCESS then
+          Field.AsLargeInt := LastInsertID;
+    SQLFreeHandle(SQL_HANDLE_STMT, STMTHandle);
     end;
-    ftDateTime:           // mapped to TDateTimeField
-    begin
-      // Seems like not all ODBC-drivers (mysql on Linux) set the fractional part. Initialize
-      // it's value to avoid 'random' data.
-      ODBCTimeStampStruct.Fraction:=0;
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_TIMESTAMP, @ODBCTimeStampStruct, SizeOf(SQL_TIMESTAMP_STRUCT), @StrLenOrInd);
-      if StrLenOrInd<>SQL_NULL_DATA then
-      begin
-        DateTime:=TimeStampStructToDateTime(@ODBCTimeStampStruct);
-        Move(DateTime, buffer^, SizeOf(TDateTime));
-      end;
-    end;
-    ftBoolean:            // mapped to TBooleanField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BIT, buffer, SizeOf(Wordbool), @StrLenOrInd);
-    ftBytes:              // mapped to TBytesField
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, FieldDef.Size, @StrLenOrInd);
-    ftVarBytes:           // mapped to TVarBytesField
-    begin
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer+SizeOf(Word), FieldDef.Size, @StrLenOrInd);
-      if StrLenOrInd < 0 then
-        PWord(buffer)^ := 0
-      else
-        PWord(buffer)^ := StrLenOrInd;
-    end;
-    ftWideMemo,
-    ftBlob, ftMemo:       // BLOBs
-    begin
-      //Writeln('BLOB');
-      // Try to discover BLOB data length
-      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, 0, @StrLenOrInd);
-      ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
-      // Read the data if not NULL
-      if StrLenOrInd<>SQL_NULL_DATA then
-      begin
-        CreateBlob:=true; // defer actual loading of blob data to LoadBlobIntoBuffer method
-        //WriteLn('Deferring loading of blob of length ',StrLenOrInd);
-      end;
-    end;
-    // TODO: Loading of other field types
-  else
-    raise EODBCException.CreateFmt('Tried to load field of unsupported field type %s',[Fieldtypenames[FieldDef.DataType]]);
-  end;
-  ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
-  Result:=StrLenOrInd<>SQL_NULL_DATA; // Result indicates whether the value is non-null
-
-  //writeln(Format('Field.Size: %d; StrLenOrInd: %d',[FieldDef.Size, StrLenOrInd]));
-end;
-
-procedure TODBCConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef; ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
-var
-  ODBCCursor: TODBCCursor;
-  Res: SQLRETURN;
-  StrLenOrInd:SQLLEN;
-  BlobBuffer:pointer;
-  BlobBufferSize,BytesRead:SQLINTEGER;
-  BlobMemoryStream:TMemoryStream;
-begin
-  ODBCCursor:=cursor as TODBCCursor;
-  // Try to discover BLOB data length
-  //   NB MS ODBC requires that TargetValuePtr is not nil, so we supply it with a valid pointer, even though BufferLength is 0
-  StrLenOrInd:=0;
-  Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, @BlobBuffer, 0, @StrLenOrInd);
-  if Res<>SQL_NO_DATA then
-    ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
-  // Read the data if not NULL
-  if StrLenOrInd<>SQL_NULL_DATA then
-  begin
-    // Determine size of buffer to use
-    if StrLenOrInd<>SQL_NO_TOTAL then begin
-      // Size is known on beforehand
-      // set size & alloc buffer
-      //WriteLn('Loading blob of length ',StrLenOrInd);
-      BlobBufferSize:=StrLenOrInd;
-      ABlobBuf^.BlobBuffer^.Size:=BlobBufferSize;
-      ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize);
-      // get blob data
-      if BlobBufferSize>0 then begin
-        Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize, @StrLenOrInd);
-        ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not load blob data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
-      end;
-    end else begin
-      // Size is not known on beforehand; read data in chuncks; write to a TMemoryStream (which implements O(n) writing)
-      BlobBufferSize:=DEFAULT_BLOB_BUFFER_SIZE;
-      // init BlobBuffer and BlobMemoryStream to nil pointers
-      BlobBuffer:=nil; // the buffer that will hold the chuncks of data; not to be confused with ABlobBuf^.BlobBuffer
-      BlobMemoryStream:=nil;
-      try
-        // Allocate the buffer and memorystream
-        BlobBuffer:=GetMem(BlobBufferSize);
-        BlobMemoryStream:=TMemoryStream.Create;
-        // Retrieve data in parts
-        repeat
-          Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, BlobBuffer, BlobBufferSize, @StrLenOrInd);
-          ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not load (partial) blob data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
-          // Append data in buffer to memorystream
-          if (StrLenOrInd=SQL_NO_TOTAL) or (StrLenOrInd>BlobBufferSize) then
-            BytesRead:=BlobBufferSize
-          else
-            BytesRead:=StrLenOrInd;
-          BlobMemoryStream.Write(BlobBuffer^, BytesRead);
-        until Res=SQL_SUCCESS;
-        // Copy memory stream data to ABlobBuf^.BlobBuffer
-        BlobBufferSize:=BlobMemoryStream.Size; // actual blob size
-        //   alloc ABlobBuf^.BlobBuffer
-        ABlobBuf^.BlobBuffer^.Size:=BlobBufferSize;
-        ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize);
-        //   read memory stream data into ABlobBuf^.BlobBuffer
-        BlobMemoryStream.Position:=0;
-        BlobMemoryStream.Read(ABlobBuf^.BlobBuffer^.Buffer^, BlobBufferSize);
-      finally
-        // free buffer and memory stream
-        BlobMemoryStream.Free;
-        if BlobBuffer<>nil then
-          Freemem(BlobBuffer,BlobBufferSize);
-      end;
-    end;
-  end;
-end;
-
-procedure TODBCConnection.FreeFldBuffers(cursor: TSQLCursor);
-var
-  ODBCCursor:TODBCCursor;
-begin
-  ODBCCursor:=cursor as TODBCCursor;
-
-  if ODBCCursor.FSTMTHandle <> SQL_NULL_HSTMT then
-    ODBCCheckResult(
-      SQLFreeStmt(ODBCCursor.FSTMTHandle, SQL_CLOSE),
-      SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not close ODBC statement cursor.'
-    );
 end;
 
 procedure TODBCConnection.AddFieldDefs(cursor: TSQLCursor; FieldDefs: TFieldDefs);
@@ -1201,6 +1122,206 @@ begin
   end;
 end;
 
+function TODBCConnection.Fetch(cursor: TSQLCursor): boolean;
+var
+  ODBCCursor:TODBCCursor;
+  Res:SQLRETURN;
+begin
+  ODBCCursor:=cursor as TODBCCursor;
+
+  // fetch new row
+  Res:=SQLFetch(ODBCCursor.FSTMTHandle);
+  if Res<>SQL_NO_DATA then
+    ODBCCheckResult(Res,SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not fetch new row from result set.');
+
+  // result is true if a new row was available
+  Result:=Res<>SQL_NO_DATA;
+end;
+
+const
+  DEFAULT_BLOB_BUFFER_SIZE = 1024;
+
+function TODBCConnection.LoadField(cursor: TSQLCursor; FieldDef: TFieldDef; buffer: pointer; out CreateBlob : boolean): boolean;
+var
+  ODBCCursor:TODBCCursor;
+  StrLenOrInd:SQLLEN;
+  ODBCDateStruct:SQL_DATE_STRUCT;
+  ODBCTimeStruct:SQL_TIME_STRUCT;
+  ODBCTimeStampStruct:SQL_TIMESTAMP_STRUCT;
+  DateTime:TDateTime;
+  Res:SQLRETURN;
+begin
+  CreateBlob := False;
+  ODBCCursor:=cursor as TODBCCursor;
+
+  // load the field using SQLGetData
+  // Note: optionally we can implement the use of SQLBindCol later for even more speed
+  // TODO: finish this
+  case FieldDef.DataType of
+    ftWideString,ftFixedWideChar: // mapped to TWideStringField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_WCHAR, buffer, FieldDef.Size+sizeof(WideChar), @StrLenOrInd); //buffer must contain space for the null-termination character
+    ftGuid, ftFixedChar,ftString: // are mapped to a TStringField (including TGuidField)
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_CHAR, buffer, FieldDef.Size+1, @StrLenOrInd);
+    ftSmallint:           // mapped to TSmallintField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SSHORT, buffer, SizeOf(Smallint), @StrLenOrInd);
+    ftInteger,ftAutoInc:  // mapped to TLongintField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SLONG, buffer, SizeOf(Longint), @StrLenOrInd);
+    ftWord:               // mapped to TWordField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_USHORT, buffer, SizeOf(Word), @StrLenOrInd);
+    ftLargeint:           // mapped to TLargeintField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_SBIGINT, buffer, SizeOf(Largeint), @StrLenOrInd);
+    ftFloat,ftCurrency:   // mapped to TFloatField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_DOUBLE, buffer, SizeOf(Double), @StrLenOrInd);
+    ftTime:               // mapped to TTimeField
+    begin
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_TIME, @ODBCTimeStruct, SizeOf(SQL_TIME_STRUCT), @StrLenOrInd);
+      if StrLenOrInd<>SQL_NULL_DATA then
+      begin
+        DateTime:=TimeStructToDateTime(@ODBCTimeStruct);
+        Move(DateTime, buffer^, SizeOf(TDateTime));
+      end;
+    end;
+    ftDate:               // mapped to TDateField
+    begin
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_DATE, @ODBCDateStruct, SizeOf(SQL_DATE_STRUCT), @StrLenOrInd);
+      if StrLenOrInd<>SQL_NULL_DATA then
+      begin
+        DateTime:=DateStructToDateTime(@ODBCDateStruct);
+        Move(DateTime, buffer^, SizeOf(TDateTime));
+      end;
+    end;
+    ftDateTime:           // mapped to TDateTimeField
+    begin
+      // Seems like not all ODBC-drivers (mysql on Linux) set the fractional part. Initialize
+      // it's value to avoid 'random' data.
+      ODBCTimeStampStruct.Fraction:=0;
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_TYPE_TIMESTAMP, @ODBCTimeStampStruct, SizeOf(SQL_TIMESTAMP_STRUCT), @StrLenOrInd);
+      if StrLenOrInd<>SQL_NULL_DATA then
+      begin
+        DateTime:=TimeStampStructToDateTime(@ODBCTimeStampStruct);
+        Move(DateTime, buffer^, SizeOf(TDateTime));
+      end;
+    end;
+    ftBoolean:            // mapped to TBooleanField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BIT, buffer, SizeOf(Wordbool), @StrLenOrInd);
+    ftBytes:              // mapped to TBytesField
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, FieldDef.Size, @StrLenOrInd);
+    ftVarBytes:           // mapped to TVarBytesField
+    begin
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer+SizeOf(Word), FieldDef.Size, @StrLenOrInd);
+      if StrLenOrInd < 0 then
+        PWord(buffer)^ := 0
+      else
+        PWord(buffer)^ := StrLenOrInd;
+    end;
+    ftWideMemo,
+    ftBlob, ftMemo:       // BLOBs
+    begin
+      //Writeln('BLOB');
+      // Try to discover BLOB data length
+      Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, buffer, 0, @StrLenOrInd);
+      ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
+      // Read the data if not NULL
+      if StrLenOrInd<>SQL_NULL_DATA then
+      begin
+        CreateBlob:=true; // defer actual loading of blob data to LoadBlobIntoBuffer method
+        //WriteLn('Deferring loading of blob of length ',StrLenOrInd);
+      end;
+    end;
+    // TODO: Loading of other field types
+  else
+    raise EODBCException.CreateFmt('Tried to load field of unsupported field type %s',[Fieldtypenames[FieldDef.DataType]]);
+  end;
+  ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
+  Result:=StrLenOrInd<>SQL_NULL_DATA; // Result indicates whether the value is non-null
+
+  //writeln(Format('Field.Size: %d; StrLenOrInd: %d',[FieldDef.Size, StrLenOrInd]));
+end;
+
+procedure TODBCConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef; ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
+var
+  ODBCCursor: TODBCCursor;
+  Res: SQLRETURN;
+  StrLenOrInd:SQLLEN;
+  BlobBuffer:pointer;
+  BlobBufferSize,BytesRead:SQLINTEGER;
+  BlobMemoryStream:TMemoryStream;
+begin
+  ODBCCursor:=cursor as TODBCCursor;
+  // Try to discover BLOB data length
+  //   NB MS ODBC requires that TargetValuePtr is not nil, so we supply it with a valid pointer, even though BufferLength is 0
+  StrLenOrInd:=0;
+  Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, @BlobBuffer, 0, @StrLenOrInd);
+  if Res<>SQL_NO_DATA then
+    ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not get field data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
+  // Read the data if not NULL
+  if StrLenOrInd<>SQL_NULL_DATA then
+  begin
+    // Determine size of buffer to use
+    if StrLenOrInd<>SQL_NO_TOTAL then begin
+      // Size is known on beforehand
+      // set size & alloc buffer
+      //WriteLn('Loading blob of length ',StrLenOrInd);
+      BlobBufferSize:=StrLenOrInd;
+      ABlobBuf^.BlobBuffer^.Size:=BlobBufferSize;
+      ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize);
+      // get blob data
+      if BlobBufferSize>0 then begin
+        Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize, @StrLenOrInd);
+        ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not load blob data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
+      end;
+    end else begin
+      // Size is not known on beforehand; read data in chuncks; write to a TMemoryStream (which implements O(n) writing)
+      BlobBufferSize:=DEFAULT_BLOB_BUFFER_SIZE;
+      // init BlobBuffer and BlobMemoryStream to nil pointers
+      BlobBuffer:=nil; // the buffer that will hold the chuncks of data; not to be confused with ABlobBuf^.BlobBuffer
+      BlobMemoryStream:=nil;
+      try
+        // Allocate the buffer and memorystream
+        BlobBuffer:=GetMem(BlobBufferSize);
+        BlobMemoryStream:=TMemoryStream.Create;
+        // Retrieve data in parts
+        repeat
+          Res:=SQLGetData(ODBCCursor.FSTMTHandle, FieldDef.Index+1, SQL_C_BINARY, BlobBuffer, BlobBufferSize, @StrLenOrInd);
+          ODBCCheckResult(Res, SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not load (partial) blob data for field "%s" (index %d).',[FieldDef.Name, FieldDef.Index+1]);
+          // Append data in buffer to memorystream
+          if (StrLenOrInd=SQL_NO_TOTAL) or (StrLenOrInd>BlobBufferSize) then
+            BytesRead:=BlobBufferSize
+          else
+            BytesRead:=StrLenOrInd;
+          BlobMemoryStream.Write(BlobBuffer^, BytesRead);
+        until Res=SQL_SUCCESS;
+        // Copy memory stream data to ABlobBuf^.BlobBuffer
+        BlobBufferSize:=BlobMemoryStream.Size; // actual blob size
+        //   alloc ABlobBuf^.BlobBuffer
+        ABlobBuf^.BlobBuffer^.Size:=BlobBufferSize;
+        ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, BlobBufferSize);
+        //   read memory stream data into ABlobBuf^.BlobBuffer
+        BlobMemoryStream.Position:=0;
+        BlobMemoryStream.Read(ABlobBuf^.BlobBuffer^.Buffer^, BlobBufferSize);
+      finally
+        // free buffer and memory stream
+        BlobMemoryStream.Free;
+        if BlobBuffer<>nil then
+          Freemem(BlobBuffer,BlobBufferSize);
+      end;
+    end;
+  end;
+end;
+
+procedure TODBCConnection.FreeFldBuffers(cursor: TSQLCursor);
+var
+  ODBCCursor:TODBCCursor;
+begin
+  ODBCCursor:=cursor as TODBCCursor;
+
+  if ODBCCursor.FSTMTHandle <> SQL_NULL_HSTMT then
+    ODBCCheckResult(
+      SQLFreeStmt(ODBCCursor.FSTMTHandle, SQL_CLOSE),
+      SQL_HANDLE_STMT, ODBCCursor.FSTMTHandle, 'Could not close ODBC statement cursor.'
+    );
+end;
+
 procedure TODBCConnection.UpdateIndexDefs(IndexDefs: TIndexDefs; TableName: string);
 var
   Len: integer;
@@ -1342,7 +1463,7 @@ begin
                 IndexDef.Options:=IndexDef.Options+[ixDescending];
               end;
             end else if (OrdinalPos=1) or not Assigned(IndexDef) then begin
-              // create new IndexDef iff OrdinalPos=1 or not Assigned(IndexDef) (the latter should not occur though)
+              // create new IndexDef if OrdinalPos=1 or not Assigned(IndexDef) (the latter should not occur though)
               IndexDef:=IndexDefs.AddIndexDef;
               IndexDef.Name:=PChar(@IndexName[1]); // treat ansistring as zero terminated string
               IndexDef.Fields:=PChar(@ColName[1]);

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

@@ -240,7 +240,7 @@ begin
     end;
 end;
 
-function Nvu2FmtBCE(b:pbyte):tBCD;
+function Nvu2FmtBCD(b:pbyte):tBCD;
 var
   i,j       : integer;
   bb,size   : byte;
@@ -370,7 +370,7 @@ begin
                             AsDateTime := ComposeDateTime(EncodeDate(odt.year,odt.month,odt.day), EncodeTime(odt.hour,odt.min,odt.sec,odt.fsec div 1000000));
                             end;
         ftFMTBcd          : begin
-                            AsFMTBCD:=Nvu2FmtBCE(ParamBuffers[i].buffer);
+                            AsFMTBCD:=Nvu2FmtBCD(ParamBuffers[i].buffer);
                             end;
         end;
 
@@ -767,30 +767,27 @@ end;
 
 function TOracleConnection.StartDBTransaction(trans: TSQLHandle; AParams: string): boolean;
 var
-  x_flags : ub4;
+  flags : ub4;
   i : Integer;
   s : string;
   locTrans : TOracleTrans;
 begin
-  locTrans := TOracleTrans(trans);
-  if ( Length(AParams) = 0 ) then begin
-    x_flags := OCI_TRANS_NEW or OCI_TRANS_READWRITE;
-  end else begin
-    x_flags := OCI_DEFAULT;
+  flags := OCI_TRANS_READWRITE;
+  if AParams <> '' then begin
     i := 1;
     s := ExtractSubStr(AParams,i,StdWordDelims);
     while ( s <> '' ) do begin
       if ( s = 'readonly' ) then
-        x_flags := x_flags and OCI_TRANS_READONLY
+        flags := OCI_TRANS_READONLY
       else if ( s = 'serializable' ) then
-        x_flags := x_flags and OCI_TRANS_SERIALIZABLE
+        flags := OCI_TRANS_SERIALIZABLE
       else if ( s = 'readwrite' ) then
-        x_flags := x_flags and OCI_TRANS_READWRITE;
+        flags := OCI_TRANS_READWRITE;
       s := ExtractSubStr(AParams,i,StdWordDelims);
     end;
-    x_flags := x_flags and OCI_TRANS_NEW;
   end;
-  locTrans.FOciFlags := x_flags;
+  locTrans := TOracleTrans(trans);
+  locTrans.FOciFlags := flags or OCI_TRANS_NEW;
   InternalStartDBTransaction(locTrans);
   Result := True;
 end;
@@ -1089,7 +1086,7 @@ begin
         move(cur,buffer^,SizeOf(Currency));
         end;
       ftFmtBCD :
-        pBCD(buffer)^:= Nvu2FmtBCE(fieldbuffers[FieldDef.FieldNo-1].buffer);
+        pBCD(buffer)^:= Nvu2FmtBCD(fieldbuffers[FieldDef.FieldNo-1].buffer);
       ftFloat :
         move(fieldbuffers[FieldDef.FieldNo-1].buffer^,buffer^,sizeof(double));
       ftSmallInt :

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

@@ -89,12 +89,14 @@ type
     FConnectString       : string;
     FIntegerDateTimes    : boolean;
     FVerboseErrors       : Boolean;
+  protected
+    // Protected so they can be used by descendents.
     procedure CheckConnectionStatus(var conn: PPGconn);
     procedure CheckResultError(var res: PPGresult; conn:PPGconn; ErrMsg: string);
     function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer; Out ATypeOID : oid) : TFieldType;
     procedure ExecuteDirectPG(const Query : String);
     Procedure GetExtendedFieldInfo(cursor: TPQCursor; Bindings : TFieldBindings);
-  protected
+
     procedure ApplyFieldUpdate(C : TSQLCursor; P: TSQLDBParam; F: TField; UseOldValue: Boolean); override;
     Function ErrorOnUnknownType : Boolean;
     // Add connection to pool.
@@ -121,12 +123,13 @@ type
     function Commit(trans : TSQLHandle) : boolean; override;
     procedure CommitRetaining(trans : TSQLHandle); override;
     function StartImplicitTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
-    function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
+    function StartDBTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
     procedure RollBackRetaining(trans : TSQLHandle); override;
     procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override;
-    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
     procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor;ATransaction : TSQLTransaction); override;
     function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
+    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
+    function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; override;
   public
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
@@ -176,6 +179,7 @@ const Oid_Bool     = 16;
       Oid_Int8     = 20;
       Oid_int2     = 21;
       Oid_Int4     = 23;
+      Oid_JSON     = 114;
       Oid_Float4   = 700;
       Oid_Money    = 790;
       Oid_Float8   = 701;
@@ -272,7 +276,7 @@ constructor TPQConnection.Create(AOwner : TComponent);
 
 begin
   inherited;
-  FConnOptions := FConnOptions + [sqSupportParams, sqSupportEmptyDatabaseName, sqEscapeRepeat, sqEscapeSlash, sqImplicitTransaction];
+  FConnOptions := FConnOptions + [sqSupportParams, sqSupportEmptyDatabaseName, sqEscapeRepeat, sqEscapeSlash, sqImplicitTransaction,sqSupportReturning];
   FieldNameQuoteChars:=DoubleQuotes;
   VerboseErrors:=True;
   FConnectionPool:=TThreadlist.Create;
@@ -331,7 +335,7 @@ begin
 {$EndIf}
 end;
 
-Procedure TPQConnection.GetExtendedFieldInfo(cursor: TPQCursor;
+procedure TPQConnection.GetExtendedFieldInfo(cursor: TPQCursor;
   Bindings: TFieldBindings);
 
 Var
@@ -386,7 +390,7 @@ begin
     P.SQLDBData:=TPQCursor(C).GetFieldBinding(F.FieldDef);
 end;
 
-Function TPQConnection.ErrorOnUnknownType: Boolean;
+function TPQConnection.ErrorOnUnknownType: Boolean;
 begin
   Result:=False;
 end;
@@ -554,8 +558,8 @@ begin
   Result := true;
 end;
 
-function TPQConnection.StartDBTransaction(trans: TSQLHandle;
-  AParams: string): boolean;
+function TPQConnection.StartDBTransaction(trans: TSQLHandle; AParams: string
+  ): boolean;
 
 Var
   res : PPGresult;
@@ -723,7 +727,7 @@ begin
 end;
 
 function TPQConnection.TranslateFldType(res: PPGresult; Tuple: integer; out
-  Size: integer; Out ATypeOID: oid): TFieldType;
+  Size: integer; out ATypeOID: oid): TFieldType;
 
 const
   VARHDRSZ=sizeof(longint);
@@ -751,7 +755,7 @@ begin
                              if size > MaxSmallint then size := MaxSmallint;
                              end;
 //    Oid_text               : Result := ftstring;
-    Oid_text               : Result := ftMemo;
+    Oid_text,Oid_JSON      : Result := ftMemo;
     Oid_Bytea              : Result := ftBlob;
     Oid_oid                : Result := ftInteger;
     Oid_int8               : Result := ftLargeInt;
@@ -804,18 +808,18 @@ begin
   end;
 end;
 
-Function TPQConnection.AllocateCursorHandle: TSQLCursor;
+function TPQConnection.AllocateCursorHandle: TSQLCursor;
 
 begin
   result := TPQCursor.create;
 end;
 
-Procedure TPQConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
+procedure TPQConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
 begin
   FreeAndNil(cursor);
 end;
 
-Function TPQConnection.AllocateTransactionHandle: TSQLHandle;
+function TPQConnection.AllocateTransactionHandle: TSQLHandle;
 
 begin
   result := TPQTrans.create;
@@ -1494,6 +1498,11 @@ begin
   result := s;
 end;
 
+function TPQConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string;
+begin
+  Result := Format('SELECT nextval(''%s'')', [SequenceName]);
+end;
+
 procedure TPQConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef;
   ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
 var

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

@@ -72,7 +72,7 @@ type
     function GetTransactionHandle(trans : TSQLHandle): pointer; override;
     function Commit(trans : TSQLHandle) : boolean; override;
     function RollBack(trans : TSQLHandle) : boolean; override;
-    function StartdbTransaction(trans : TSQLHandle; aParams : string) : boolean; override;
+    function StartDBTransaction(trans : TSQLHandle; aParams : string) : boolean; override;
     procedure CommitRetaining(trans : TSQLHandle); override;
     procedure RollBackRetaining(trans : TSQLHandle); override;
 
@@ -88,6 +88,8 @@ type
     constructor Create(AOwner : TComponent); override;
     procedure GetFieldNames(const TableName : string; List :  TStrings); override;
     function GetConnectionInfo(InfoType:TConnInfoType): string; override;
+    procedure CreateDB; override;
+    procedure DropDB; override;
     function GetInsertID: int64;
     // See http://www.sqlite.org/c3ref/create_collation.html for detailed information
     // If eTextRep=0 a default UTF-8 compare function is used (UTF8CompareCallback)
@@ -176,7 +178,6 @@ Var
   I : Integer;
   P : TParam;  
   str1: string;
-  do1: double;
   wstr1: widestring;
   
 begin
@@ -189,23 +190,16 @@ begin
       case P.DataType of
         ftInteger,
         ftAutoInc,
-        ftBoolean,
         ftSmallint: checkerror(sqlite3_bind_int(fstatement,I,P.AsInteger));
         ftWord:     checkerror(sqlite3_bind_int(fstatement,I,P.AsWord));
+        ftBoolean:  checkerror(sqlite3_bind_int(fstatement,I,ord(P.AsBoolean)));
         ftLargeint: checkerror(sqlite3_bind_int64(fstatement,I,P.AsLargeint));
         ftBcd,
         ftFloat,
-        ftCurrency:
-                begin
-                do1:= P.AsFloat;
-                checkerror(sqlite3_bind_double(fstatement,I,do1));
-                end;
+        ftCurrency: checkerror(sqlite3_bind_double(fstatement, I, P.AsFloat));
         ftDateTime,
         ftDate,
-        ftTime: begin
-                do1:= P.AsFloat - JulianEpoch;
-                checkerror(sqlite3_bind_double(fstatement,I,do1));
-                end;
+        ftTime:     checkerror(sqlite3_bind_double(fstatement, I, P.AsFloat - JulianEpoch));
         ftFMTBcd:
                 begin
                 str1:=BCDToStr(P.AsFMTBCD, Fconnection.FSQLFormatSettings);
@@ -334,12 +328,12 @@ begin
   ABlobBuf^.BlobBuffer^.Size := int1;
 end;
 
-Function TSQLite3Connection.AllocateTransactionHandle: TSQLHandle;
+function TSQLite3Connection.AllocateTransactionHandle: TSQLHandle;
 begin
  result:= tsqlhandle.create;
 end;
 
-Function TSQLite3Connection.AllocateCursorHandle: TSQLCursor;
+function TSQLite3Connection.AllocateCursorHandle: TSQLCursor;
 
 Var
   Res : TSQLite3Cursor;
@@ -350,7 +344,7 @@ begin
   Result:=Res;
 end;
 
-Procedure TSQLite3Connection.DeAllocateCursorHandle(var cursor: TSQLCursor);
+procedure TSQLite3Connection.DeAllocateCursorHandle(var cursor: TSQLCursor);
 begin
   freeandnil(cursor);
 end;
@@ -583,18 +577,13 @@ begin
     if TryStrToInt(NextWord(S,':'),Min) then
     begin
       if TryStrToInt(NextWord(S,'.'),Sec) then
-      begin // 23:59:59 or 23:59:59.999
-      MSec:=StrToIntDef(S,0);
-      if Interval then
-        Result:=EncodeTimeInterval(Hour,Min,Sec,MSec)
-      else
-        Result:=EncodeTime(Hour,Min,Sec,MSec);
+        // 23:59:59 or 23:59:59.999
+        MSec:=StrToIntDef(S,0)
+      else // 23:59
+      begin
+        Sec:=0;
+        MSec:=0;
       end;
-    end
-    else //23:59
-    begin
-      Sec:=0;
-      MSec:=0;
       if Interval then
         Result:=EncodeTimeInterval(Hour,Min,Sec,MSec)
       else
@@ -763,8 +752,7 @@ begin
   result:= true;
 end;
 
-function TSQLite3Connection.StartdbTransaction(trans: TSQLHandle;
-               aParams: string): boolean;
+function TSQLite3Connection.StartDBTransaction(trans: TSQLHandle; aParams: string): boolean;
 begin
   execsql('BEGIN');
   result:= true;
@@ -784,15 +772,15 @@ end;
 
 procedure TSQLite3Connection.DoInternalConnect;
 var
-  str1: string;
+  filename: ansistring;
 begin
   Inherited;
-  if Length(databasename)=0 then
+  if DatabaseName = '' then
     DatabaseError(SErrNoDatabaseName,self);
-  if (SQLiteLoadedLibrary='') then
+  if SQLiteLoadedLibrary = '' then
     InitializeSqlite(SQLiteDefaultLibrary);
-  str1:= databasename;
-  checkerror(sqlite3_open(pchar(str1),@fhandle));
+  filename := DatabaseName;
+  checkerror(sqlite3_open(PAnsiChar(filename),@fhandle));
   if (Length(Password)>0) and assigned(sqlite3_key) then
     checkerror(sqlite3_key(fhandle,PChar(Password),StrLen(PChar(Password))));
   if Params.IndexOfName('foreign_keys') <> -1 then
@@ -984,7 +972,7 @@ function TSQLite3Connection.GetConnectionInfo(InfoType: TConnInfoType): string;
 begin
   Result:='';
   try
-    InitializeSqlite(SQLiteDefaultLibrary);
+    InitializeSqlite;
     case InfoType of
       citServerType:
         Result:=TSQLite3ConnectionDef.TypeName;
@@ -1003,6 +991,30 @@ begin
   end;
 end;
 
+procedure TSQLite3Connection.CreateDB;
+var filename: ansistring;
+begin
+  CheckDisConnected;
+  try
+    InitializeSqlite;
+    try
+      filename := DatabaseName;
+      checkerror(sqlite3_open(PAnsiChar(filename),@fhandle));
+    finally
+      sqlite3_close(fhandle);
+      fhandle := nil;
+    end;
+  finally
+    ReleaseSqlite;
+  end;
+end;
+
+procedure TSQLite3Connection.DropDB;
+begin
+  CheckDisConnected;
+  DeleteFile(DatabaseName);
+end;
+
 function UTF8CompareCallback(user: pointer; len1: longint; data1: pointer; len2: longint; data2: pointer): longint; cdecl;
 var S1, S2: AnsiString;
 begin

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

@@ -309,6 +309,7 @@ const
   //sqlite2.x.x and sqlite3.x.x define these constants equally
   SQLITE_OK = 0;
   SQLITE_ROW = 100;
+  SQLITE_DONE = 101;
   
   NullString = 'NULL';
   
@@ -560,6 +561,8 @@ var
   TempItem: PDataRecord;
 begin
   Result := False;
+  if ABookmark = nil then
+    Exit;
   TempItem := FBeginItem^.Next;
   while TempItem <> FEndItem do
   begin
@@ -756,10 +759,7 @@ begin
   case GetMode of
     gmPrior:
       if (FCurrentItem^.Previous = FBeginItem) or (FCurrentItem = FBeginItem) then
-      begin
-        Result := grBOF;
-        FCurrentItem := FBeginItem;
-      end
+        Result := grBOF
       else
         FCurrentItem:=FCurrentItem^.Previous;
     gmCurrent:
@@ -790,15 +790,13 @@ function TCustomSqliteDataset.GetRecNo: Integer;
 var
   TempItem, TempActive: PDataRecord;
 begin
-  Result := -1;
+  Result := 0;
   if (FRecordCount = 0) or (State = dsInsert) then
     Exit;  
   TempItem := FBeginItem;
   TempActive := PPDataRecord(ActiveBuffer)^;
   if TempActive = FCacheItem then // Record is being edited
     TempActive := FInternalActiveBuffer;
-  //RecNo is 1 based
-  Inc(Result);
   while TempActive <> TempItem do
   begin
     if TempItem^.Next <> nil then
@@ -808,9 +806,8 @@ begin
     end  
     else
     begin
-      Result := -1;
+      Result := 0;
       DatabaseError('GetRecNo - ActiveItem Not Found', Self);
-      break;
     end;      
   end;  
 end;
@@ -885,14 +882,16 @@ var
 begin
   Dec(FRecordCount);
   TempItem := PPDataRecord(ActiveBuffer)^;
+  if TempItem = FCacheItem then // Record is being edited
+    TempItem := FInternalActiveBuffer;
   TempItem^.Next^.Previous := TempItem^.Previous;
   TempItem^.Previous^.Next := TempItem^.Next;
   if FCurrentItem = TempItem then
   begin
-    if FCurrentItem^.Previous <> FBeginItem then
-      FCurrentItem := FCurrentItem^.Previous
+    if FCurrentItem^.Next <> FEndItem then
+      FCurrentItem := FCurrentItem^.Next
     else
-      FCurrentItem := FCurrentItem^.Next;  
+      FCurrentItem := FCurrentItem^.Previous;  
   end; 
   // Dec FNextAutoInc (only if deleted item is the last record)  
   if FAutoIncFieldNo <> -1 then
@@ -1424,39 +1423,40 @@ begin
   end;
 end;
 
-// Specific functions 
+// Specific functions
 
-procedure TCustomSqliteDataset.SetDetailFilter;
-  function FieldToSqlStr(AField: TField): String;
+function GetFieldEqualExpression(AField: TField): String;
+begin
+  if not AField.IsNull then
   begin
-    if not AField.IsNull then
-    begin
-      case AField.DataType of
-        //todo: handle " caracter properly
-        ftString, ftMemo:
-          Result := '"' + AField.AsString + '"';
-        ftDateTime, ftDate, ftTime:
-          Str(AField.AsDateTime, Result);
-      else
-        Result := AField.AsString;
-      end; //case
-    end
+    case AField.DataType of
+      //todo: handle " caracter properly
+      ftString, ftMemo:
+        Result := '"' + AField.AsString + '"';
+      ftDateTime, ftDate, ftTime:
+        Str(AField.AsDateTime, Result);
     else
-      Result:=NullString;
-  end; //function
+      Result := AField.AsString;
+    end; //case
+    Result := ' = ' + Result;
+  end
+  else
+    Result := ' IS NULL';
+end;
 
+procedure TCustomSqliteDataset.SetDetailFilter;
 var
   AFilter: String;
   i: Integer;
 begin
-  if not FMasterLink.Active or (FMasterLink.Dataset.RecordCount = 0) then //Retrieve all data
+  if not FMasterLink.Active then //Retrieve all data
     FEffectiveSQL := FSqlFilterTemplate
   else
   begin
     AFilter := ' where ';
     for i := 0 to FMasterLink.Fields.Count - 1 do
     begin
-      AFilter := AFilter + IndexFields[i].FieldName + ' = ' + FieldToSqlStr(TField(FMasterLink.Fields[i]));
+      AFilter := AFilter + IndexFields[i].FieldName + GetFieldEqualExpression(TField(FMasterLink.Fields[i]));
       if i <> FMasterLink.Fields.Count - 1 then
         AFilter := AFilter + ' and ';
     end;
@@ -1783,7 +1783,7 @@ begin
     WriteLn('  SQL: ',SqlTemp);
     {$endif}
     ExecSQL(SQLTemp);
-    Result := FReturnCode = SQLITE_OK;
+    Result := FReturnCode = SQLITE_DONE;
   end
   else
     Result := False;

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

@@ -141,7 +141,7 @@ begin
   sqlite3_open(PAnsiChar(FFileName), @Result);
   //sqlite3_open returns SQLITE_OK even for invalid files
   //do additional check here
-  FReturnCode := sqlite3_prepare(Result, CheckFileSql, -1, @vm, nil);
+  FReturnCode := sqlite3_prepare_v2(Result, CheckFileSql, -1, @vm, nil);
   if FReturnCode <> SQLITE_OK then
   begin
     ErrorStr := SqliteCode2Str(FReturnCode) + ' - ' + sqlite3_errmsg(Result);
@@ -163,7 +163,7 @@ begin
   {$endif}
   FAutoIncFieldNo := -1;
   FieldDefs.Clear;
-  FReturnCode := sqlite3_prepare(FSqliteHandle, PAnsiChar(FEffectiveSQL), -1, @vm, nil);
+  FReturnCode := sqlite3_prepare_v2(FSqliteHandle, PAnsiChar(FEffectiveSQL), -1, @vm, nil);
   if FReturnCode <> SQLITE_OK then
     DatabaseError(ReturnString, Self);
   sqlite3_step(vm);
@@ -263,7 +263,7 @@ procedure TSqlite3Dataset.ExecuteDirect(const ASQL: String);
 var
   vm: Pointer;
 begin
-  FReturnCode := sqlite3_prepare(FSqliteHandle, PAnsiChar(ASQL), -1, @vm, nil);
+  FReturnCode := sqlite3_prepare_v2(FSqliteHandle, PAnsiChar(ASQL), -1, @vm, nil);
   if FReturnCode <> SQLITE_OK then
     DatabaseError(ReturnString, Self);
   FReturnCode := sqlite3_step(vm);
@@ -281,7 +281,7 @@ begin
     sqlite3_exec(FSqliteHandle, PAnsiChar('Select Max(' + FieldDefs[FAutoIncFieldNo].Name +
       ') from ' + FTableName), @GetAutoIncValue, @FNextAutoInc, nil);
 
-  FReturnCode := sqlite3_prepare(FSqliteHandle, PAnsiChar(FEffectiveSQL), -1, @vm, nil);
+  FReturnCode := sqlite3_prepare_v2(FSqliteHandle, PAnsiChar(FEffectiveSQL), -1, @vm, nil);
   if FReturnCode <> SQLITE_OK then
     DatabaseError(ReturnString, Self);
 
@@ -367,7 +367,7 @@ begin
   if FSqliteHandle = nil then
     GetSqliteHandle;
   Result := '';
-  FReturnCode := sqlite3_prepare(FSqliteHandle,PAnsiChar(ASQL), -1, @vm, nil);
+  FReturnCode := sqlite3_prepare_v2(FSqliteHandle,PAnsiChar(ASQL), -1, @vm, nil);
   if FReturnCode <> SQLITE_OK then
     DatabaseError(ReturnString, Self);
     

packages/fcl-db/tests/database.ini.txt

@@ -228,4 +228,10 @@ connector=bufdataset
 ; sdfdataset file-based dataset:
 connector=sdfds
 ; subdirectory for the sdf files:
-name=sdftest
+name=sdftest
+
+[sqlite3dataset]
+; TSqlite3Dataset dataset:
+connector=sqlite3ds
+; datafile
+name=testsqlite3ds.db

packages/fcl-db/tests/dbtestframework.pas

@@ -28,7 +28,7 @@ uses
   TestSpecificTBufDataset,
   TestSpecificTDBF,
   TestSpecificTMemDataset,
-  TestDBExport,
+  TestDBExport, tccsvdataset,
   consoletestrunner;
 
 Procedure LegacyOutput;

packages/fcl-db/tests/dbtestframework_gui.lpi

@@ -18,7 +18,7 @@
     <VersionInfo>
       <StringTable ProductVersion=""/>
     </VersionInfo>
-    <BuildModes Count="4">
+    <BuildModes Count="5">
       <Item1 Name="Default" Default="True"/>
       <Item2 Name="debug">
         <CompilerOptions>
@@ -27,12 +27,6 @@
             <IncludeFiles Value="$(ProjOutDir)"/>
             <OtherUnitFiles Value="../src/base;../src/sqldb/odbc;../src/sqldb/mssql;../src/sqldb/sqlite;../src/sqldb/postgres;../src/sqldb/oracle;../src/memds;../src/sqldb;../src/sqldb/interbase;../src/sqldb/mysql;../src/dbase;../src/sdf"/>
           </SearchPaths>
-          <Other>
-            <CompilerMessages>
-              <UseMsgFile Value="True"/>
-            </CompilerMessages>
-            <CompilerPath Value="$(CompPath)"/>
-          </Other>
         </CompilerOptions>
       </Item2>
       <Item3 Name="Default_no_local_ppus">
@@ -46,12 +40,6 @@
               <GenerateDebugInfo Value="False"/>
             </Debugging>
           </Linking>
-          <Other>
-            <CompilerMessages>
-              <UseMsgFile Value="True"/>
-            </CompilerMessages>
-            <CompilerPath Value="$(CompPath)"/>
-          </Other>
         </CompilerOptions>
       </Item3>
       <Item4 Name="Default_no_local_ppus_debug">
@@ -65,14 +53,20 @@
               <OptimizationLevel Value="0"/>
             </Optimizations>
           </CodeGeneration>
+        </CompilerOptions>
+      </Item4>
+      <Item5 Name="TestSqlite3DS">
+        <CompilerOptions>
+          <Version Value="11"/>
+          <SearchPaths>
+            <IncludeFiles Value="$(ProjOutDir)"/>
+            <OtherUnitFiles Value="../src/base;../src/sqldb/odbc;../src/sqldb/mssql;../src/sqldb/sqlite;../src/sqldb/postgres;../src/sqldb/oracle;../src/memds;../src/sqldb;../src/sqldb/interbase;../src/sqldb/mysql;../src/dbase;../src/sdf;../src/export"/>
+          </SearchPaths>
           <Other>
-            <CompilerMessages>
-              <UseMsgFile Value="True"/>
-            </CompilerMessages>
-            <CompilerPath Value="$(CompPath)"/>
+            <CustomOptions Value="-dTEST_SQLITE3DS"/>
           </Other>
         </CompilerOptions>
-      </Item4>
+      </Item5> 
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
@@ -82,7 +76,6 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
     <RequiredPackages Count="4">
@@ -99,17 +92,25 @@
         <PackageName Value="FCL"/>
       </Item4>
     </RequiredPackages>
-    <Units Count="2">
+    <Units Count="4">
       <Unit0>
         <Filename Value="dbtestframework_gui.lpr"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="dbtestframework_gui"/>
+        <UnitName Value="DBGuiTestRunner"/> 
       </Unit0>
       <Unit1>
         <Filename Value="dbguitestrunner.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="DBGuiTestRunner"/>
       </Unit1>
+      <Unit2>
+        <Filename Value="tccsvdataset.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="sqlite3dstoolsunit.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="Sqlite3DSToolsUnit"/>
+      </Unit3>
     </Units>
   </ProjectOptions>
   <CompilerOptions>
@@ -123,12 +124,6 @@
         <GenerateDebugInfo Value="False"/>
       </Debugging>
     </Linking>
-    <Other>
-      <CompilerMessages>
-        <UseMsgFile Value="True"/>
-      </CompilerMessages>
-      <CompilerPath Value="$(CompPath)"/>
-    </Other>
   </CompilerOptions>
   <Debugging>
     <Exceptions Count="7">

packages/fcl-db/tests/dbtestframework_gui.lpr

@@ -24,7 +24,9 @@ uses
   bufdatasettoolsunit,
   memdstoolsunit,
   SdfDSToolsUnit,
-  tcsdfdata,
+{$IFDEF TEST_SQLITE3DS}
+  Sqlite3DSToolsUnit,
+{$ENDIF}
   // DB unittest
   TestBasics,
   TestDBBasics,
@@ -35,6 +37,8 @@ uses
   TestSpecificTBufDataset,
   TestSpecificTDBF,
   TestSpecificTMemDataset,
+  tcsdfdata,
+  tccsvdataset,
   TestDBExport;
 
 {$R *.res}

packages/fcl-db/tests/memdstoolsunit.pas

@@ -7,7 +7,7 @@ interface
 uses
   Classes, SysUtils, toolsunit,
   db,
-  Memds;
+  MemDS;
 
 type
 { TMemDSConnector }
@@ -81,7 +81,7 @@ begin
   testTimeValues[2] := '23:59:59.000';
   testTimeValues[3] := '23:59:59.003';
 
-  MemDs := TMemDataset.Create(nil);
+  MemDS := TMemDataset.Create(nil);
   with MemDS do
     begin
     Name := 'FieldDataset';
@@ -100,6 +100,11 @@ begin
     FieldDefs.Add('FFIXEDCHAR',ftFixedChar,10);
     FieldDefs.Add('FLARGEINT',ftLargeint);
     FieldDefs.Add('FFMTBCD',ftFmtBCD);
+    FieldDefs.Add('FBLOB',ftBlob);
+    FieldDefs.Add('FMEMO',ftMemo);
+    FieldDefs.Add('FWIDESTRING',ftWideString);
+    FieldDefs.Add('FFIXEDWIDECHAR',ftFixedWideChar);
+    FieldDefs.Add('FWIDEMEMO',ftWideMemo);
     CreateTable;
     Open;
     for i := 0 to testValuesCount-1 do
@@ -120,6 +125,11 @@ begin
       FieldByName('FFIXEDCHAR').AsString := PadRight(testStringValues[i], 10);
       FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i];
       FieldByName('FFMTBCD').AsBCD := StrToBCD(testFmtBCDValues[i], Self.FormatSettings);
+      FieldByName('FBLOB').AsString := testValues[ftBlob, i];
+      FieldByName('FMEMO').AsString := testValues[ftMemo, i];
+      FieldByName('FWIDESTRING').AsWideString := testValues[ftWideString, i];
+      FieldByName('FFIXEDWIDECHAR').AsWideString := testValues[ftFixedWideChar, i];
+      FieldByName('FWIDEMEMO').AsWideString := testValues[ftWideMemo, i];
       Post;
       end;
     Close;

packages/fcl-db/tests/sdfdstoolsunit.pas

@@ -71,8 +71,6 @@ begin
         // work properly)
         Post;
         end;
-      if state = dsinsert then
-        Post;
       Close;
       Free;
       end;
@@ -86,11 +84,11 @@ begin
   with TSdfDataSet.Create(nil) do
     begin
     FileName := dbname+PathDelim+'fpdev_field.dat';
-      DeleteFile(FileName);
     // Make sure the directory exists so we can write
     ForceDirectories(dbname);
+    DeleteFile(FileName);
     FileMustExist:=False;
-    
+
     SetFieldDatasetSchema(Schema);
 
     Open;
@@ -102,6 +100,7 @@ begin
       Post;
       end;
     Close;
+    Free;
     end;
 end;
 
@@ -134,10 +133,10 @@ begin
     begin
     FileName := dbname+PathDelim+'fpdev_field.dat';
     SetFieldDatasetSchema(Schema);
+    TrimSpace := False;
     end;
 end;
 
 initialization
   RegisterClass(TSdfDSDBConnector);
-end.
-
+end.

packages/fcl-db/tests/sqlite3dstoolsunit.pas

@@ -0,0 +1,203 @@
+unit Sqlite3DSToolsUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, toolsunit
+  ,db, Sqlite3DS
+  ;
+
+
+const
+  STestNotApplicable = 'This test does not apply to this sqlite3ds connection type';
+
+
+type
+  { TSqlite3DSDBConnector }
+
+  TSqlite3DSDBConnector = class(TDBConnector)
+  private
+    FDataset: TSqlite3Dataset;
+    Function CreateDataset: TSqlite3Dataset;
+  protected
+    procedure CreateNDatasets; override;
+    procedure CreateFieldDataset; override;
+    procedure DropNDatasets; override;
+    procedure DropFieldDataset; override;
+    Function InternalGetNDataset(n : integer) : TDataset; override;
+    Function InternalGetFieldDataset : TDataSet; override;
+  public
+    procedure TryDropIfExist(const ATableName : String);
+    destructor Destroy; override;
+    constructor Create; override;
+    procedure ExecuteDirect(const SQL: string);
+  end;
+
+
+implementation
+
+{ TSqlite3DSDBConnector }
+
+function TSqlite3DSDBConnector.CreateDataset: TSqlite3Dataset;
+
+begin
+  Result := TSqlite3Dataset.create(nil);
+  Result.FileName := dbname;
+end;
+
+procedure TSqlite3DSDBConnector.CreateNDatasets;
+var CountID : Integer;
+begin
+  try
+    TryDropIfExist('FPDEV');
+    FDataset.ExecSQL('create table FPDEV (' +
+                              '  ID INT NOT NULL,  ' +
+                              '  NAME VARCHAR(50), ' +
+                              '  PRIMARY KEY (ID)  ' +
+                              ')');
+    FDataset.ExecSQL('BEGIN;');
+    for countID := 1 to MaxDataSet do
+      FDataset.ExecSQL('insert into FPDEV (ID,NAME) ' +
+                                'values ('+inttostr(countID)+',''TestName'+inttostr(countID)+''')');
+    FDataset.ExecSQL('COMMIT;');
+  except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running CreateNDatasets: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+procedure TSqlite3DSDBConnector.CreateFieldDataset;
+var
+  FieldDataset: TSqlite3Dataset;
+  i: Integer;
+
+begin
+  FieldDataset := CreateDataset;
+  try
+    TryDropIfExist('FPDEV_FIELD');
+    with FieldDataset do
+    begin
+       TableName := 'FPDEV_FIELD';
+       PrimaryKey := 'ID';
+       FieldDefs.Add('ID', ftInteger);
+       FieldDefs.Add('FSTRING', ftString, 10);
+       //FieldDefs.Add('FSMALLINT', ftSmallint);
+       FieldDefs.Add('FINTEGER', ftInteger);
+       FieldDefs.Add('FWORD', ftWord);
+       FieldDefs.Add('FBOOLEAN', ftBoolean);
+       FieldDefs.Add('FFLOAT', ftFloat);
+       FieldDefs.Add('FCURRENCY', ftCurrency);
+       //FieldDefs.Add('FBCD', ftBCD);
+       FieldDefs.Add('FDATE', ftDate);
+       FieldDefs.Add('FDATETIME', ftDateTime);
+       FieldDefs.Add('FLARGEINT', ftLargeint);
+       FieldDefs.Add('FMEMO', ftMemo);
+       if not CreateTable then
+         raise Exception.Create('Error in CreateTable: ' + FieldDataset.ReturnString);
+       Open;
+       for i := 0 to testValuesCount - 1 do
+       begin
+         Append;
+         FieldByName('ID').AsInteger := i;
+         FieldByName('FSTRING').AsString := testStringValues[i];
+         //FieldByName('FSMALLINT').AsInteger := testSmallIntValues[i];
+         FieldByName('FINTEGER').AsInteger := testIntValues[i];
+         FieldByName('FWORD').AsInteger := testWordValues[i];
+         FieldByName('FBOOLEAN').AsBoolean := testBooleanValues[i];
+         FieldByName('FFLOAT').AsFloat := testFloatValues[i];
+         FieldByName('FCURRENCY').AsCurrency := testCurrencyValues[i];
+         // work around missing TBCDField.AsBCD:
+         //  FieldByName('FBCD').AsBCD := StrToBCD(testFmtBCDValues[i],Self.FormatSettings);
+         FieldByName('FDATE').AsDateTime := StrToDate(testDateValues[i], 'yyyy/mm/dd', '-');
+         FieldByName('FDATETIME').AsDateTime := StrToDateTime(testValues[ftDateTime,i], Self.FormatSettings);
+         FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i];
+         FieldByName('FMEMO').AsString := testStringValues[i];
+         Post;
+       end;
+       if not ApplyUpdates then
+         raise Exception.Create('Error in ApplyUpdates: ' + FieldDataset.ReturnString);
+       Destroy;
+     end;
+  except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running CreateFieldDataset: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+procedure TSqlite3DSDBConnector.DropNDatasets;
+begin
+  try
+    FDataset.ExecSQL('DROP TABLE FPDEV');
+  Except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running DropNDatasets: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+procedure TSqlite3DSDBConnector.DropFieldDataset;
+begin
+  try
+    FDataset.ExecSQL('DROP TABLE FPDEV_FIELD');
+  Except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running DropFieldDataset: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+function TSqlite3DSDBConnector.InternalGetNDataset(n: integer): TDataset;
+begin
+  Result := CreateDataset;
+  with (Result as TSqlite3Dataset) do
+    begin
+    sql := 'SELECT * FROM FPDEV WHERE ID < '+inttostr(n+1)+' ORDER BY ID';
+    end;
+end;
+
+function TSqlite3DSDBConnector.InternalGetFieldDataset: TDataSet;
+begin
+  Result := CreateDataset;
+  with (Result as TSqlite3Dataset) do
+    begin
+    sql := 'SELECT * FROM FPDEV_FIELD';
+    end;
+end;
+
+procedure TSqlite3DSDBConnector.TryDropIfExist(const ATableName: String);
+begin
+  FDataset.ExecSQL('drop table if exists ' + ATableName);
+end;
+
+procedure TSqlite3DSDBConnector.ExecuteDirect(const SQL: string);
+begin
+  FDataset.ExecSQL(SQL);
+end;
+
+destructor TSqlite3DSDBConnector.Destroy;
+begin
+  inherited Destroy;
+  FDataset.Destroy;
+end;
+
+constructor TSqlite3DSDBConnector.Create;
+begin
+  FDataset := CreateDataset;
+  Inherited;
+end;
+
+initialization
+  RegisterClass(TSqlite3DSDBConnector);
+end.

packages/fcl-db/tests/tccsvdataset.pp

@@ -0,0 +1,404 @@
+unit tccsvdataset;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, db, SysUtils, fpcunit, testutils, testregistry, csvdataset;
+
+type
+
+  { TTestCSVDataset }
+
+  TTestCSVDataset= class(TTestCase)
+  private
+    FCSVDataset: TCSVDataset;
+    // Load CSVDataset from CSV stream containing lines
+    Procedure LoadFromLines(Const Lines: Array of string);
+    // Save CSVDataset to CSV stream, transform to lines
+    Procedure SaveToLines(Const Lines: TStrings);
+    // Save CSVDataset to CSV stream, transform to lines, compare with given lines
+    Procedure AssertLines(Const Lines: Array of string);
+  protected
+    procedure SetUp; override;
+    procedure TearDown; override;
+    Property CSVDataset : TCSVDataset Read FCSVDataset;
+  published
+    procedure TestEmpty;
+    procedure TestDefaults;
+    Procedure TestLoadEmptyDefault;
+    Procedure TestLoadEmptyFirstLineAsNames;
+    Procedure TestLoad2fieldsFirstLineAsNames;
+    Procedure TestLoad2fields;
+    Procedure TestLoad2Records2fields;
+    Procedure TestSaveEmptyDefault;
+    Procedure TestSaveEmptyFirstLineAsNames;
+    Procedure TestSaveOneRecordDefault;
+    Procedure TestSaveOneRecordFirstLineAsNames;
+    Procedure TestSaveTwoRecordsDefault;
+    Procedure TestSaveTwoRecordsFirstLineAsNames;
+    Procedure TestSaveOneRecord2FieldsDefault;
+    Procedure TestSaveOneRecord2FieldsFirstLineAsNames;
+    Procedure TestLoadPriorFieldDefs;
+    Procedure TestLoadPriorFieldDefsNoFieldNames;
+    Procedure TestLoadPriorFieldDefsNoFieldNamesWrongCount;
+    Procedure TestLoadPriorFieldDefsFieldNamesWrongCount;
+    Procedure TestLoadPriorFieldDefsFieldNamesWrongNames;
+  end;
+
+implementation
+
+procedure TTestCSVDataset.TestEmpty;
+begin
+  AssertNotNull('Have CSV dataset',CSVDataset);
+  AssertFalse('Not open',CSVDataset.Active);
+  AssertEquals('No fielddefs',0,CSVDataset.FieldDefs.Count);
+  AssertEquals('Name','DS',CSVDataset.Name);
+end;
+
+procedure TTestCSVDataset.TestDefaults;
+begin
+  With CSVDataset.CSVOptions do
+    begin
+    AssertEquals('DefaultFieldLength',255,DefaultFieldLength);
+    AssertEquals('FirstLineAsFieldNames',False,FirstLineAsFieldNames);
+    AssertEquals('Delimiter',',',Delimiter);
+    AssertEquals('QuoteChar','"',QuoteChar);
+    AssertEquals('LineEnding',sLineBreak,LineEnding);
+    AssertEquals('IgnoreOuterWhitespace',False,IgnoreOuterWhitespace);
+    AssertEquals('QuoteOuterWhitespace',True,QuoteOuterWhitespace);
+    AssertEquals('EqualColCountPerRow',True,EqualColCountPerRow);
+    end;
+end;
+
+Procedure TTestCSVDataset.LoadFromLines(Const Lines : Array of string);
+
+Var
+  L : TStringList;
+  s : TStream;
+begin
+  S:=Nil;
+  L:=TStringList.Create;
+  try
+    L.AddStrings(Lines);
+    S:=TStringStream.Create(L.Text);
+    CSVDataset.LoadFromCSVStream(S);
+  finally
+    S.Free;
+    L.Free;
+  end;
+end;
+
+Procedure TTestCSVDataset.SaveToLines(Const Lines: TStrings);
+
+Var
+  S : TStringStream;
+
+begin
+  S:=TStringStream.Create('');
+  try
+    CSVDataset.SaveToCSVStream(S);
+    Lines.Text:=S.DataString;
+    {
+    Writeln('----');
+    Writeln(S.DataString);
+    Writeln('----');
+    }
+  finally
+    S.Free;
+  end;
+end;
+
+Procedure TTestCSVDataset.AssertLines(Const Lines: Array of string);
+
+Var
+  L : TStrings;
+  I : Integer;
+begin
+  L:=TStringList.Create;
+  try
+    SaveToLines(L);
+    AssertEquals('Number of lines',Length(Lines),L.Count);
+    For I:=0 to L.Count-1 do
+      AssertEquals('Correct line '+IntToStr(0),Lines[I],L[i]);
+  finally
+    L.Free;
+  end;
+end;
+
+Procedure TTestCSVDataset.TestLoadEmptyDefault;
+begin
+  LoadFromLines(['a']);
+  AssertEquals('Active',True,CSVDataset.Active);
+  AssertEquals('field count',1,CSVDataset.FieldDefs.Count);
+  AssertEquals('field name','Column1',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('Not Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('field contents','a',CSVDataset.Fields[0].AsString);
+end;
+
+Procedure TTestCSVDataset.TestLoadEmptyFirstLineAsNames;
+
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.CSVOptions.DefaultFieldLength:=128;
+  LoadFromLines(['a']);
+  AssertEquals('Active',True,CSVDataset.Active);
+  AssertEquals('field count',1,CSVDataset.FieldDefs.Count);
+  AssertEquals('field name','a',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('Empty',True,CSVDataset.EOF and CSVDataset.BOF);
+end;
+
+Procedure TTestCSVDataset.TestLoad2fieldsFirstLineAsNames;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.CSVOptions.DefaultFieldLength:=128;
+  LoadFromLines(['a,b']);
+  AssertEquals('Active',True,CSVDataset.Active);
+  AssertEquals('field count',2,CSVDataset.FieldDefs.Count);
+  AssertEquals('field 0 name','a',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field 0 size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('field 1 name','b',CSVDataset.FieldDefs[1].Name);
+  AssertEquals('field 1 size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[1].Size);
+  AssertEquals('Empty',True,CSVDataset.EOF and CSVDataset.BOF);
+end;
+
+Procedure TTestCSVDataset.TestLoad2fields;
+
+begin
+  CSVDataset.CSVOptions.DefaultFieldLength:=128;
+  LoadFromLines(['a,b']);
+  AssertEquals('Active',True,CSVDataset.Active);
+  AssertEquals('field count',2,CSVDataset.FieldDefs.Count);
+  AssertEquals('field 0 name','Column1',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field 0 size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('field 1 name','Column2',CSVDataset.FieldDefs[1].Name);
+  AssertEquals('field 1 size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[1].Size);
+  AssertEquals('Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('Not Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('field 0 contents','a',CSVDataset.Fields[0].AsString);
+  AssertEquals('field 1 contents','b',CSVDataset.Fields[1].AsString);
+end;
+
+Procedure TTestCSVDataset.TestLoad2Records2fields;
+begin
+  CSVDataset.CSVOptions.DefaultFieldLength:=128;
+  LoadFromLines(['a,b','c,d']);
+  AssertEquals('Active',True,CSVDataset.Active);
+  AssertEquals('field count',2,CSVDataset.FieldDefs.Count);
+  AssertEquals('field 0 name','Column1',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field 0 size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('field 1 name','Column2',CSVDataset.FieldDefs[1].Name);
+  AssertEquals('field 1 size',CSVDataset.CSVOptions.DefaultFieldLength,CSVDataset.FieldDefs[1].Size);
+  AssertEquals('Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('Not Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('field 0 contents','a',CSVDataset.Fields[0].AsString);
+  AssertEquals('field 1 contents','b',CSVDataset.Fields[1].AsString);
+  CSVDataset.Next;
+  AssertEquals('not At EOF',False,CSVDataset.EOF);
+  AssertEquals('field 0 contents','c',CSVDataset.Fields[0].AsString);
+  AssertEquals('field 1 contents','d',CSVDataset.Fields[1].AsString);
+  CSVDataset.Next;
+  AssertEquals('At EOF',True,CSVDataset.EOF);
+end;
+
+Procedure TTestCSVDataset.TestSaveEmptyDefault;
+begin
+  CSVDataset.FieldDefs.Add('a',ftString);
+  CSVDataset.CreateDataset;
+  AssertLines([]);
+end;
+
+Procedure TTestCSVDataset.TestSaveEmptyFirstLineAsNames;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString);
+  CSVDataset.CreateDataset;
+  AssertLines(['a']);
+end;
+
+Procedure TTestCSVDataset.TestSaveOneRecordDefault;
+begin
+//  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.CreateDataset;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='b';
+  CSVDataset.Post;
+  AssertLines(['b']);
+end;
+
+Procedure TTestCSVDataset.TestSaveOneRecordFirstLineAsNames;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.CreateDataset;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='b';
+  CSVDataset.Post;
+  AssertLines(['a','b']);
+end;
+
+Procedure TTestCSVDataset.TestSaveTwoRecordsDefault;
+begin
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.CreateDataset;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='b';
+  CSVDataset.Post;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='c';
+  CSVDataset.Post;
+  AssertLines(['b','c']);
+end;
+
+Procedure TTestCSVDataset.TestSaveTwoRecordsFirstLineAsNames;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.CreateDataset;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='b';
+  CSVDataset.Post;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='c';
+  CSVDataset.Post;
+  AssertLines(['a','b','c']);
+end;
+
+Procedure TTestCSVDataset.TestSaveOneRecord2FieldsDefault;
+begin
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftString,20);
+  CSVDataset.CreateDataset;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='c';
+  CSVDataset.Fields[1].AsString:='d';
+  CSVDataset.Post;
+  AssertLines(['c,d']);
+end;
+
+Procedure TTestCSVDataset.TestSaveOneRecord2FieldsFirstLineAsNames;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftString,20);
+  CSVDataset.CreateDataset;
+  CSVDataset.Append;
+  CSVDataset.Fields[0].AsString:='c';
+  CSVDataset.Fields[1].AsString:='d';
+  CSVDataset.Post;
+  AssertLines(['a,b','c,d']);
+end;
+
+Procedure TTestCSVDataset.TestLoadPriorFieldDefs;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftInteger,4);
+  LoadFromLines(['a,b','1,2']);
+  AssertEquals('field count',2,CSVDataset.FieldDefs.Count);
+  AssertEquals('field 0 name','a',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field 0 size',20,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('field 1 name','b',CSVDataset.FieldDefs[1].Name);
+  AssertEquals('field 1 size',4,CSVDataset.FieldDefs[1].Size);
+  AssertEquals('field 1 typee',Ord(ftInteger),Ord(CSVDataset.FieldDefs[1].DataType));
+  AssertEquals('Not Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('field 0 contents','1',CSVDataset.Fields[0].AsString);
+  AssertEquals('field 1 contents',2,CSVDataset.Fields[1].AsInteger);
+end;
+
+Procedure TTestCSVDataset.TestLoadPriorFieldDefsNoFieldNames;
+begin
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftInteger,4);
+  LoadFromLines(['1,2']);
+  AssertEquals('field count',2,CSVDataset.FieldDefs.Count);
+  AssertEquals('field 0 name','a',CSVDataset.FieldDefs[0].Name);
+  AssertEquals('field 0 size',20,CSVDataset.FieldDefs[0].Size);
+  AssertEquals('field 1 name','b',CSVDataset.FieldDefs[1].Name);
+  AssertEquals('field 1 size',4,CSVDataset.FieldDefs[1].Size);
+  AssertEquals('field 1 typee',Ord(ftInteger),Ord(CSVDataset.FieldDefs[1].DataType));
+  AssertEquals('Not Empty',False,CSVDataset.EOF and CSVDataset.BOF);
+  AssertEquals('field 0 contents','1',CSVDataset.Fields[0].AsString);
+  AssertEquals('field 1 contents',2,CSVDataset.Fields[1].AsInteger);
+end;
+
+Procedure TTestCSVDataset.TestLoadPriorFieldDefsNoFieldNamesWrongCount;
+
+Var
+  OK : Boolean;
+begin
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftInteger,4);
+  try
+    LoadFromLines(['1']);
+    OK:=False;
+  except
+    OK:=true;
+  end;
+  if not OK then
+    Fail('Expected exception, but none raised');
+end;
+
+Procedure TTestCSVDataset.TestLoadPriorFieldDefsFieldNamesWrongCount;
+
+const
+  EM = 'DS : CSV File Field count (1) does not match dataset field count (2).';
+Var
+  OK : String;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftInteger,4);
+  try
+    LoadFromLines(['A']);
+    OK:='Expected exception, but none raised';
+  except
+    on E : Exception do
+      if  (E.Message<>EM) then
+        OK:=ComparisonMsg(EM,E.Message);
+  end;
+  if (OK<>'') then
+    Fail(OK);
+end;
+
+Procedure TTestCSVDataset.TestLoadPriorFieldDefsFieldNamesWrongNames;
+const
+  EM = 'DS : CSV File field 1: name "c" does not match dataset field name "b".';
+Var
+  OK : String;
+begin
+  CSVDataset.CSVOptions.FirstLineAsFieldNames:=True;
+  CSVDataset.FieldDefs.Add('a',ftString,20);
+  CSVDataset.FieldDefs.Add('b',ftInteger,4);
+  try
+    LoadFromLines(['a,c']);
+    OK:='No exception raised';
+  except
+    on E : Exception do
+      if  (E.Message<>EM) then
+        OK:=ComparisonMsg(EM,E.Message)
+  end;
+  if (OK<>'') then
+    Fail(OK);
+end;
+
+procedure TTestCSVDataset.SetUp;
+begin
+  FCSVDataset:=TCSVDataset.Create(Nil);
+  FCSVDataset.Name:='DS';
+end;
+
+procedure TTestCSVDataset.TearDown;
+begin
+  FreeAndNil(FCSVDataset);
+end;
+
+Initialization
+
+  RegisterTest(TTestCSVDataset);
+end.
+

packages/fcl-db/tests/tcsdfdata.pp

@@ -1,21 +1,24 @@
 unit tcsdfdata;
-// Tests specific functionality of sdfdataset (multiline etc)
+// Tests specific functionality of SdfDataSet (multiline etc)
+//                             and FixedFormatDataSet
 
 {$mode objfpc}{$H+}
 
 interface
 
 uses
-  Classes, SysUtils, Fpcunit, Testutils, Testregistry, testdecorator,
+  Classes, SysUtils, Fpcunit, TestRegistry,
   dateutils,sdfdata,ToolsUnit;
 
 type
 
-  { Ttestsdfspecific }
+  { TTestSdfSpecific }
 
-  Ttestsdfspecific = class(Ttestcase)
+  TTestSdfSpecific = class(TTestCase)
+  private
+    TestDataset: TSdfDataset;
+    function TestFileName(const FileName: string=''): string;
   protected
-    TestDataset: TSDFDataset;
     procedure Setup; override;
     procedure Teardown; override;
   published
@@ -24,28 +27,55 @@ type
     procedure TestSingleLineHeader;
     procedure TestSingleLineNoHeader;
     procedure TestOutput;
-    {
-    November 2012: this test tests again sdf;
-    however sdfdataset should comply with RFC4180 CSV, see issue #22980
-    todo: rewrite test to RFC4180
-    procedure TestInputOurFormat;
-    }
     procedure TestDelimitedTextOutput;
+    procedure TestEmptyFieldHeader;
+    Procedure TestEmptyFieldNoHeader;
+    procedure TestEmptyFieldContents;
+    Procedure TestEmptyFieldHeaderStripTrailingDelimiters;
+    Procedure TestStripTrailingDelimiters;
+  end;
+
+  { TTestFixedFormatSpecific }
+
+  TTestFixedFormatSpecific = class(TTestCase)
+  private
+    TestDataset: TFixedFormatDataset;
+    function TestFileName(const FileName: string=''): string;
+    procedure CreateTestFile;
+  protected
+    procedure Setup; override;
+    procedure Teardown; override;
+  published
+    procedure TestTrimSpace;
+    procedure TestNoTrimSpace;
   end;
 
 implementation
 
-procedure Ttestsdfspecific.TestEmptyFileHeader;
-// An empty file should return 0 records even if it has a header
+function Ttestsdfspecific.TestFileName(const FileName: string): string;
 const
-  InputFilename='empty.csv';
+  DefaultTestFileName = 'test.csv';
 begin
-  TestDataSet.Close;
+  if FileName = '' then
+    Result := DefaultTestFileName
+  else
+    Result := FileName;
 
-  if FileExists(InputFilename) then DeleteFile(InputFilename);
-  TestDataset.FileMustExist:=false;
-  TestDataset.FirstLineAsSchema := True;  
-  TestDataset.FileName:=InputFilename;
+  if dbname <> '' then
+    begin
+    ForceDirectories(dbname);
+    Result := IncludeTrailingPathDelimiter(dbname) + Result;
+    end;
+
+  if FileExists(Result) then DeleteFile(Result);
+end;
+
+procedure Ttestsdfspecific.TestEmptyFileHeader;
+// An empty file should return 0 records even if it has a header
+begin
+  // with Schema, with Header line
+  TestDataset.FirstLineAsSchema := True;
+  TestDataset.FileName := TestFileName('empty.csv');
   TestDataset.Open;
 
   TestDataset.Last;
@@ -56,15 +86,10 @@ end;
 
 procedure Ttestsdfspecific.TestEmptyFileNoHeader;
 // An empty file should return 0 records even if it has a header
-const
-  InputFilename='empty.csv';
 begin
-  TestDataSet.Close;
-
-  if FileExists(InputFilename) then DeleteFile(InputFilename);
-  TestDataset.FileMustExist:=false;
-  TestDataset.FirstLineAsSchema := false;  
-  TestDataset.FileName:=InputFilename;
+  // with Schema, without Header line
+  TestDataset.FirstLineAsSchema := False;
+  TestDataset.FileName := TestFileName('empty.csv');
   TestDataset.Open;
 
   TestDataset.Last;
@@ -75,176 +100,131 @@ end;
 
 procedure Ttestsdfspecific.TestSingleLineHeader;
 // A file with a single data line and header should return 1 records
-const
-  InputFilename='singleh.csv';
 var
   FileStrings: TStringList;
 begin
-  TestDataSet.Close;
+  // with Schema, with Header line, which differs from Schema
+  TestDataset.FirstLineAsSchema := True;
+  TestDataset.FileName := TestFileName('singleh.csv');
 
-  if FileExists(InputFilename) then DeleteFile(InputFilename);
   FileStrings:=TStringList.Create;
   try
-    FileStrings.Add('ID,NAME,BIRTHDAY');
-    FileStrings.Add('1,SimpleName,31-12-1976');
-    FileStrings.SaveToFile(InputFileName);
+    FileStrings.Add('ID,NAME,BIRTHDAY,GENDER'); // 4 fields override 3 fields in Schema
+    FileStrings.Add('1,SimpleName,31-12-1976,M');
+    FileStrings.SaveToFile(TestDataset.FileName);
   finally
     FileStrings.Free;
   end;
 
-  TestDataset.FileMustExist:=false;
-  TestDataset.FirstLineAsSchema := true;
-  TestDataset.FileName:=InputFilename;
   TestDataset.Open;
+  AssertEquals('FieldDefs.Count', 4, TestDataset.FieldDefs.Count);
+  AssertEquals('1', TestDataset.Fields[0].AsString); // just after Open
 
   TestDataset.Last;
   TestDataset.First;
-  AssertEquals('Number of records in test dataset', 1, TestDataset.RecordCount);
+  AssertEquals('RecNo', 1, TestDataset.RecNo);
+  AssertEquals('RecordCount', 1, TestDataset.RecordCount);
   TestDataset.Close;
+  AssertEquals('RecordCount after Close', 0, TestDataset.RecordCount);
 end;
 
 procedure Ttestsdfspecific.TestSingleLineNoHeader;
 // A file with a single data line, no header should return 1 records
-const
-  InputFilename='single.csv';
 var
   FileStrings: TStringList;
 begin
-  TestDataSet.Close;
+  // with Schema, without Header line
+  TestDataset.FirstLineAsSchema := False;
+  TestDataset.FileName := TestFileName('singleh.csv');
 
-  if FileExists(InputFilename) then DeleteFile(InputFilename);
   FileStrings:=TStringList.Create;
   try
     FileStrings.Add('1,SimpleName,31-12-1976');
-    FileStrings.SaveToFile(InputFileName);
+    FileStrings.SaveToFile(TestDataset.FileName);
   finally
     FileStrings.Free;
   end;
 
-  TestDataset.FileMustExist:=false;
-  TestDataset.FirstLineAsSchema := false;
-  TestDataset.FileName:=InputFilename;
   TestDataset.Open;
+  AssertEquals('FieldDefs.Count', 3, TestDataset.FieldDefs.Count);
+  AssertEquals('1', TestDataset.Fields[0].AsString);
 
   TestDataset.Last;
   TestDataset.First;
-  AssertEquals('Number of records in test dataset', 1, TestDataset.RecordCount);
+  AssertEquals('RecNo', 1, TestDataset.RecNo);
+  AssertEquals('RecordCount', 1, TestDataset.RecordCount);
   TestDataset.Close;
+  AssertEquals('RecordCount after Close', 0, TestDataset.RecordCount);
 end;
 
 procedure Ttestsdfspecific.TestOutput;
 // Basic assignment test: assign some difficult data to records and
-// see if the recordcount is correct.
+// see if the RecordCount is correct.
 const
-  OutputFilename='output.csv';
+  NAME: array[1..4] of string = (
+    'J"T"',                             // Data with quotes
+    'Hello, goodbye',                   // Data with delimiter
+    '  Just a line with spaces     ',   // Regular data
+    'Delimiter,"and";quote'             // Data with delimiter and quote
+  );
+var
+  i: integer;
 begin
-  TestDataSet.Close;
-
-  if FileExists(OutputFilename) then DeleteFile(OutputFileName);
-  TestDataset.FileName:=OutputFileName;
+  // with Schema, with Header line
+  TestDataset.Schema[1] := 'NAME=30';
+  TestDataset.FileName := TestFileName('output.csv');
   TestDataset.Open;
+
   // Fill test data
   TestDataset.Append;
   TestDataset.FieldByName('ID').AsInteger := 1;
-  // Data with quotes
-  TestDataset.FieldByName('NAME').AsString := 'J"T"';
+  TestDataset.FieldByName('NAME').AsString := NAME[1];
   TestDataset.FieldByName('BIRTHDAY').AsDateTime := ScanDateTime('yyyymmdd', '19761231', 1);
   TestDataset.Post;
 
   TestDataset.Append;
   TestDataset.FieldByName('ID').AsInteger := 2;
-  // Data with delimiter
-  TestDataset.FieldByName('NAME').AsString := 'Hello'+TestDataset.Delimiter+' goodbye';
+  TestDataset.FieldByName('NAME').AsString := NAME[2];
   TestDataset.FieldByName('BIRTHDAY').AsDateTime := ScanDateTime('yyyymmdd', '19761231', 1);
   TestDataset.Post;
 
   TestDataset.Append;
-  TestDataset.FieldByName('ID').AsInteger := 3;
-  //Data with delimiter and quote (to test 19376)
-  TestDataset.FieldByName('NAME').AsString := 'Delimiter,"and";quote';
+  TestDataset.FieldByName('ID').AsInteger := 4;
+  TestDataset.FieldByName('NAME').AsString := NAME[4];
   TestDataset.FieldByName('BIRTHDAY').AsDateTime := ScanDateTime('yyyymmdd', '19761231', 1);
   TestDataset.Post;
 
-
-  TestDataset.Append;
-  TestDataset.FieldByName('ID').AsInteger := 4;
-  // Regular data
-  TestDataset.FieldByName('NAME').AsString := 'Just a long line of text without anything special';
+  TestDataset.Insert;
+  TestDataset.FieldByName('ID').AsInteger := 3;
+  TestDataset.FieldByName('NAME').AsString := NAME[3];
   TestDataset.FieldByName('BIRTHDAY').AsDateTime := ScanDateTime('yyyymmdd', '19761231', 1);
   TestDataset.Post;
 
-  TestDataset.Last;
+  // test sequential order of records
   TestDataset.First;
-  // This fails - seems it sees the header as a record, too?
-  AssertEquals('Number of records in test dataset', 4, TestDataset.RecordCount);
-  TestDataset.Close;
-end;
-
-{
-procedure Ttestsdfspecific.TestInputOurFormat;
-// Test if input works as expected: output is written according to specs and read in.
-// Mainly check if reading quotes is according to Delphi sdf specs and works.
-// See test results from bug 19610 for evidence that the strings below should work.
-// If this works, we can switch to this and be RFC 4180 compliant and Delphi compliant.
-const
-  OutputFileName='input.csv';
-  //Value1 is the on disk format; it should translate to Expected1
-  Value1='"Delimiter,""and"";quote"';
-  Expected1='Delimiter,"and";quote';
-  Value2='"J""T"""';
-  Expected2='J"T"';
-  Value3='Just a long line';
-  Expected3='Just a long line';
-  //Note: Delphi can read this, see evidence in bug 19610 (the "quoted and space" value)
-  Value4='"Just a quoted long line"';
-  Expected4='Just a quoted long line';
-  // Delphi can read multiline, see evidence in bug 19610 (the multiline entry)
-  Value5='"quoted_multi'+#13+#10+'line"';
-  Expected5='quoted_multi'+#13+#10+'line';
-  Value6='"Delimiter,and;quoted"';
-  Expected6='Delimiter,and;quoted';
-  Value7='"A random""quote"';
-  Expected7='A random"quote';
-var
-  FileStrings: TStringList;
-begin
-  TestDataset.Close;
-  TestDataset.AllowMultiLine:=true;
-  if FileExists(OutputFilename) then DeleteFile(OutputFileName);
-  FileStrings:=TStringList.Create;
-  try
-    FileStrings.Add('ID,NAME,BIRTHDAY');
-    FileStrings.Add('1,'+Value1+',31-12-1976');
-    FileStrings.Add('2,'+Value2+',31-12-1976');
-    FileStrings.Add('3,'+Value3+',31-12-1976');
-    FileStrings.Add('4,'+Value4+',31-12-1976');
-    FileStrings.Add('5,'+Value5+',31-12-1976');
-    FileStrings.Add('6,'+Value6+',31-12-1976');
-    FileStrings.Add('7,'+Value7+',31-12-1976');
-    FileStrings.SaveToFile(OutputFileName);
-  finally
-    FileStrings.Free;
+  for i:=1 to 4 do begin
+    AssertEquals('RecNo', i, TestDataset.RecNo);
+    AssertEquals(i, TestDataset.FieldByName('ID').AsInteger);
+    TestDataset.Next;
   end;
+  // set/test RecNo
+  for i:=1 to 4 do begin
+    TestDataset.RecNo := i;
+    AssertEquals('RecNo', i, TestDataset.RecNo);
+    AssertEquals(i, TestDataset.FieldByName('ID').AsInteger);
+  end;
+  AssertEquals('RecordCount', 4, TestDataset.RecordCount);
+  TestDataset.Close;
+  AssertEquals('RecordCount after Close', 0, TestDataset.RecordCount);
 
-  // Load our dataset
-  TestDataset.FileName:=OutputFileName;
+  // reopen, retest
   TestDataset.Open;
-  TestDataset.First;
-  AssertEquals(Expected1, TestDataSet.FieldByName('NAME').AsString);
-  TestDataSet.Next;
-  AssertEquals(Expected2, TestDataSet.FieldByName('NAME').AsString);
-  TestDataSet.Next;
-  AssertEquals(Expected3, TestDataSet.FieldByName('NAME').AsString);
-  TestDataSet.Next;
-  AssertEquals(Expected4, TestDataSet.FieldByName('NAME').AsString);
-  TestDataSet.Next;
-  AssertEquals(Expected5, TestDataSet.FieldByName('NAME').AsString);
-  TestDataSet.Next;
-  AssertEquals(Expected6, TestDataSet.FieldByName('NAME').AsString);
-  TestDataSet.Next;
-  AssertEquals(Expected7, TestDataSet.FieldByName('NAME').AsString);
+  for i:=1 to 4 do begin
+    AssertEquals(NAME[i], TestDataset.FieldByName('NAME').AsString);
+    TestDataset.Next;
+  end;
+  AssertTrue('Eof', TestDataset.Eof);
 end;
-}
 
 procedure Ttestsdfspecific.TestDelimitedTextOutput;
 // Test if saving and loading data keeps the original values.
@@ -252,7 +232,6 @@ procedure Ttestsdfspecific.TestDelimitedTextOutput;
 // Mainly check if writing & reading quotes works.
 // to do: more fully test RFC4180
 const
-  OutputFileName='delim.csv';
   Value1='Delimiter,"and";quote';
   Value2='J"T"';
   Value3='Just a long line';
@@ -260,45 +239,182 @@ const
   Value5='multi'+#13+#10+'line';
   Value6='Delimiter,and;done';
   Value7='Some "random" quotes';
-var
-  FileStrings: TStringList;
-  OneRecord: TStringList;
+Var
+  F : Text;
 begin
+  // with Schema, with Header line
   TestDataset.Close;
-  TestDataset.AllowMultiLine:=true;
-  if FileExists(OutputFileName) then DeleteFile(OutputFileName);
-  FileStrings:=TStringList.Create;
-  OneRecord:=TStringList.Create;
-  try
-    FileStrings.Add('Field1,Field2,Field3,Field4,Field5,Field6,Field7');
-    OneRecord.Add(Value1);
-    OneRecord.Add(Value2);
-    OneRecord.Add(Value3);
-    OneRecord.Add(Value4);
-    OneRecord.Add(Value5);
-    OneRecord.Add(Value6);
-    OneRecord.Add(Value7);
-    OneRecord.Delimiter:=',';
-    OneRecord.QuoteChar:='"';
-    OneRecord.StrictDelimiter:=true;
-    FileStrings.Add(OneRecord.DelimitedText);
-    FileStrings.SaveToFile(OutputFileName);
-  finally
-    FileStrings.Free;
-    OneRecord.Free;
-  end;
-
+  TestDataset.AllowMultiLine := True;
+  TestDataset.FirstLineAsSchema := True;
+  TestDataset.FileName := TestFileName('delim.csv');
+  Assign(F, TestDataset.FileName);
+  Rewrite(F);
+  Writeln(F,'Field1,Field2,Field3,Field4,Field5,Field6,Field7');
+  Writeln(F,'"Delimiter,""and"";quote","J""T""",Just a long line,"Just a quoted long line","multi');
+  Writeln(F,'line","Delimiter,and;done","Some ""random"" quotes"');
+  Close(F);
   // Load our dataset
-  TestDataset.FileName:=OutputFileName;
   TestDataset.Open;
+//  AssertEquals('Field count',7,TestDataset.FieldDefs.Count);
+//  AssertEquals('Record count',1,TestDataset.RecordCount);
   TestDataset.First;
-  AssertEquals(Value1, TestDataSet.Fields[0].AsString);
-  AssertEquals(Value2, TestDataSet.Fields[1].AsString);
-  AssertEquals(Value3, TestDataSet.Fields[2].AsString);
-  AssertEquals(Value4, TestDataSet.Fields[3].AsString);
-  AssertEquals(Value5, TestDataSet.Fields[4].AsString);
-  AssertEquals(Value6, TestDataSet.Fields[5].AsString);
-  AssertEquals(Value7, TestDataSet.Fields[6].AsString);
+  AssertEquals('Field1', Value1, TestDataSet.Fields[0].AsString);
+  AssertEquals('Field2', Value2, TestDataSet.Fields[1].AsString);
+  AssertEquals('Field3', Value3, TestDataSet.Fields[2].AsString);
+  AssertEquals('Field4', Value4, TestDataSet.Fields[3].AsString);
+  AssertEquals('Field5', Value5, TestDataSet.Fields[4].AsString);
+  AssertEquals('Field6', Value6, TestDataSet.Fields[5].AsString);
+  AssertEquals('Field7' ,Value7, TestDataSet.Fields[6].AsString);
+end;
+
+procedure Ttestsdfspecific.TestEmptyFieldContents;
+Var
+  F : Text;
+begin
+  // with empty Field name in Header line
+  TestDataset.FirstLineAsSchema := True;
+  TestDataset.Delimiter := ';';
+  TestDataset.FileName := TestFileName();
+
+  Assign(F, TestDataset.FileName);
+  Rewrite(F);
+  Writeln(F,'1;2;3;;5');
+  Writeln(F,'11;12;13;;15');
+  Close(F);
+
+  TestDataset.Open;
+  AssertEquals('FieldDefs.Count',5,TestDataset.FieldDefs.Count);
+  AssertEquals('RecordCount',1,TestDataset.RecordCount);
+end;
+
+procedure Ttestsdfspecific.TestEmptyFieldHeader;
+Var
+  F : Text;
+begin
+  // with empty Field name in Header line
+  TestDataset.Delimiter := ';';
+  TestDataset.FirstLineAsSchema := True;
+  TestDataset.FileName := TestFileName();
+
+  Assign(F, TestDataset.FileName);
+  Rewrite(F);
+  Writeln(F,'1;2;3;;5');
+  Close(F);
+
+  TestDataset.Open;
+  AssertEquals('FieldDefs.Count',5,TestDataset.FieldDefs.Count);
+  AssertEquals('RecordCount', 0, TestDataset.RecordCount);
+end;
+
+procedure Ttestsdfspecific.TestEmptyFieldNoHeader;
+
+Var
+  F : Text;
+  S1,S2 : String;
+
+begin
+  // without Schema, without Header line
+  TestDataset.Schema.Clear;
+  TestDataset.FirstLineAsSchema := False;
+  TestDataset.Delimiter := ';';
+  TestDataset.FileName := TestFileName();
+
+  Assign(F, TestDataset.FileName);
+  Rewrite(F);
+  Writeln(F,'value1;value2;;;');
+  Close(F);
+
+  with TestDataset do begin
+    Open;
+    AssertEquals('FieldDefs.Count', 5, FieldDefs.Count);
+    AssertEquals('RecordCount', 1, RecordCount);
+    // #1 record
+    Edit;
+    Fields[0].AsString := 'Value1';
+    Post;
+    AssertEquals('Fields[4]', '', Fields[4].AsString);
+    // #2 record
+    Append;
+    Fields[1].AsString := 'Value2';
+    Fields[2].AsString := 'Value"'; // embedded double quote
+    Post;
+    Close;
+  end;
+
+  Assign(F, TestDataset.FileName);
+  Reset(F);
+  ReadLn(F,S1);
+  ReadLn(F,S2);
+  Close(F);
+  AssertEquals('Value1;value2;;;',S1);
+  AssertEquals(';Value2;"Value""";;',S2);
+end;
+
+procedure Ttestsdfspecific.TestEmptyFieldHeaderStripTrailingDelimiters;
+Var
+  F : Text;
+  S : String;
+
+begin
+  // without Schema, without Header line
+  TestDataset.Schema.Clear;
+  TestDataset.FirstLineAsSchema := False;
+  TestDataset.Delimiter := ';';
+  TestDataset.StripTrailingDelimiters := True;
+  TestDataset.FileName := TestFileName();
+
+  Assign(F, TestDataset.FileName);
+  Rewrite(F);
+  Writeln(F,'value1;value2;;;');
+  Close(F);
+
+  TestDataset.Open;
+  AssertEquals('FieldDefs.Count',2,TestDataset.FieldDefs.Count);
+  TestDataset.Edit;
+  TestDataset.Fields[0].AsString:='Value1';
+  TestDataset.Post;
+  TestDataset.Close;
+
+  Assign(F, TestDataset.FileName);
+  Reset(F);
+  ReadLn(F,S);
+  Close(F);
+  AssertEquals('No data lost','Value1;value2',S);
+end;
+
+procedure Ttestsdfspecific.TestStripTrailingDelimiters;
+Var
+  F : Text;
+  S1,S2 : String;
+
+begin
+  // without Schema, with Header line
+  TestDataset.Schema.Clear;
+  TestDataset.FirstLineAsSchema := True;
+  TestDataset.Delimiter := ';';
+  TestDataset.StripTrailingDelimiters := True;
+  TestDataset.FileName := TestFileName();;
+
+  Assign(F, TestDataset.FileName);
+  Rewrite(F);
+  Writeln(F,'value1;value2;;;');
+  Writeln(F,'value1;value2;;;');
+  Close(F);
+
+  TestDataset.Open;
+  AssertEquals('FieldDefs.Count',2,TestDataset.FieldDefs.Count);
+  TestDataset.Edit;
+  TestDataset.Fields[0].AsString:='Value1';
+  TestDataset.Post;
+  TestDataset.Close;
+
+  Assign(F, TestDataset.FileName);
+  Reset(F);
+  ReadLn(F,S1);
+  ReadLn(F,S2);
+  Close(F);
+  AssertEquals('Headers lost','value1;value2;;;',S1); // should striping affect also header line ?
+  AssertEquals('Data lost','Value1;value2',S2);
 end;
 
 
@@ -307,8 +423,10 @@ procedure Ttestsdfspecific.Setup;
 begin
   TestDataset := TSDFDataset.Create(nil);
   TestDataset.Delimiter := ',';
-  TestDataset.FileMustExist:=false;
+  TestDataset.FileMustExist := False;
   TestDataset.FirstLineAsSchema := True;
+  TestDataset.TrimSpace := False;
+  TestDataset.AllowMultiLine := False;
   TestDataset.Schema.Add('ID');
   TestDataset.Schema.Add('NAME');
   TestDataset.Schema.Add('BIRTHDAY');
@@ -330,13 +448,119 @@ begin
   end;
 end;
 
+
+{ TTestFixedFormatSpecific }
+
+procedure TTestFixedFormatSpecific.Setup;
+begin
+  TestDataset := TFixedFormatDataset.Create(nil);
+  TestDataset.FileMustExist := False;
+  TestDataset.Schema.Add('ID=1');
+  TestDataset.Schema.Add('NAME=10');
+  TestDataset.Schema.Add('BIRTHDAY=10');
+end;
+
+procedure TTestFixedFormatSpecific.Teardown;
+begin
+  TestDataSet.Close;
+  TestDataSet.Free;
+end;
+
+function TTestFixedFormatSpecific.TestFileName(const FileName: string): string;
+const
+  DefaultTestFileName = 'test.sdf';
+begin
+  if FileName = '' then
+    Result := DefaultTestFileName
+  else
+    Result := FileName;
+
+  if dbname <> '' then
+    begin
+    ForceDirectories(dbname);
+    Result := IncludeTrailingPathDelimiter(dbname) + Result;
+    end;
+
+  if FileExists(Result) then DeleteFile(Result);
+end;
+
+procedure TTestFixedFormatSpecific.CreateTestFile;
+var
+  FileStrings: TStringList;
+begin
+  FileStrings:=TStringList.Create;
+  try
+    FileStrings.Add('1John      2000-01-01');
+    FileStrings.Add('2Christiana2001-02-02');
+    FileStrings.SaveToFile(TestDataset.FileName);
+  finally
+    FileStrings.Free;
+  end;
+end;
+
+procedure TTestFixedFormatSpecific.TestTrimSpace;
+begin
+  TestDataset.FileName := TestFileName();
+  CreateTestFile;
+
+  with TestDataset do begin
+    Open;
+    AssertEquals('FieldDefs.Count', 3, FieldDefs.Count);
+    AssertEquals('1', Fields[0].AsString); // just after Open
+
+    Last;
+    First;
+    AssertEquals('RecNo', 1, RecNo);
+    AssertEquals('RecordCount', 2, RecordCount);
+    AssertEquals('1', Fields[0].AsString);
+    AssertEquals('John', Fields[1].AsString);
+    Next;
+    AssertEquals('2', Fields[0].AsString);
+    AssertEquals('Christiana', Fields[1].AsString);
+    Edit;
+    Fields[1].AsString := 'Chris';
+    Post;
+    AssertEquals('Chris', Fields[1].AsString);
+    Close; // save changes
+    AssertEquals('RecordCount after Close', 0, RecordCount);
+    Open;
+    Next;
+    AssertEquals('Chris', Fields[1].AsString);
+  end;
+end;
+
+procedure TTestFixedFormatSpecific.TestNoTrimSpace;
+begin
+  TestDataset.FileName := TestFileName();
+  CreateTestFile;
+
+  with TestDataset do begin
+    TrimSpace := False;
+    Open;
+    AssertEquals('1', Fields[0].AsString);
+    AssertEquals('John      ', Fields[1].AsString);
+    Next;
+    AssertEquals('2', Fields[0].AsString);
+    AssertEquals('Christiana', Fields[1].AsString);
+    Edit;
+    Fields[1].AsString := 'Chris';
+    Post;
+    AssertEquals('Chris     ', Fields[1].AsString);
+    Close; // save changes
+    Open;
+    Next;
+    AssertEquals('Chris     ', Fields[1].AsString);
+  end;
+end;
+
 initialization
   // Only run these tests if we are running
   // sdf tests. After all, running these when testing
   // e.g. SQL RDBMS doesn't make sense.
   if uppercase(dbconnectorname)='SDFDS' then
     begin
-    Registertest(Ttestsdfspecific);
+    RegisterTest(TTestSdfSpecific);
+    RegisterTest(TTestFixedFormatSpecific);
     end;
 end.
 

packages/fcl-db/tests/testdbbasics.pas

@@ -199,7 +199,7 @@ type THackDataLink=class(TDataLink);
 
 procedure TTestCursorDBBasics.TestAppendOnEmptyDataset;
 begin
-  with DBConnector.GetNDataset(0) do
+  with DBConnector.GetNDataset(True,0) do
     begin
     open;
     CheckTrue(CanModify);
@@ -217,7 +217,7 @@ end;
 
 procedure TTestCursorDBBasics.TestInsertOnEmptyDataset;
 begin
-  with DBConnector.GetNDataset(0) do
+  with DBConnector.GetNDataset(True,0) do
     begin
     open;
     CheckTrue(CanModify);
@@ -454,17 +454,17 @@ var
 begin
   query1:= DBConnector.GetNDataset(11);
   datalink1:= TDataLink.create;
-  datasource1:= tdatasource.create(nil);
+  datasource1:= TDataSource.create(nil);
   try
-    datalink1.datasource:= datasource1;
-    datasource1.dataset:= query1;
+    datalink1.DataSource:= datasource1;
+    datasource1.DataSet:= query1;
 
-    query1.active := true;
+    query1.active := True;
     query1.active := False;
     CheckEquals(0, THackDataLink(datalink1).RecordCount);
-    query1.active := true;
+    query1.active := True;
     CheckTrue(THackDataLink(datalink1).RecordCount>0);
-    query1.active := false;
+    query1.active := False;
   finally
     datalink1.free;
     datasource1.free;
@@ -488,13 +488,11 @@ begin
     CheckEquals(count,RecordCount);
 
     Close;
-
     end;
 end;
 
 procedure TTestCursorDBBasics.TestRecNo;
-var i       : longint;
-    passed  : boolean;
+var passed  : boolean;
 begin
   with DBConnector.GetNDataset(0) do
     begin
@@ -502,68 +500,86 @@ begin
     // return 0
     passed := false;
     try
-      i := recno;
+      passed := RecNo = 0;
     except on E: Exception do
-      begin
       passed := E.classname = EDatabaseError.className
-      end;
     end;
     if not passed then
       CheckEquals(0,RecNo,'Failed to get the RecNo from a closed dataset');
 
-    // Accessing Recordcount on a closed dataset should raise an EDatabaseError or should
+    // Accessing RecordCount on a closed dataset should raise an EDatabaseError or should
     // return 0
     passed := false;
     try
-      i := recordcount;
+      passed := RecordCount = 0;
     except on E: Exception do
-      begin
       passed := E.classname = EDatabaseError.className
-      end;
     end;
     if not passed then
-      CheckEquals(0,RecNo,'Failed to get the Recordcount from a closed dataset');
+      CheckEquals(0,RecordCount,'Failed to get the RecordCount from a closed dataset');
 
     Open;
 
-    CheckEquals(0,RecordCount);
-    CheckEquals(0,RecNo);
+    CheckEquals(0,RecordCount,'1. record count after open');
+    CheckEquals(0,RecNo,'1. recno after open');
+    CheckEquals(True,EOF and BOF, '1. Empty');
 
     first;
-    CheckEquals(0,RecordCount);
-    CheckEquals(0,RecNo);
+    CheckEquals(0,RecordCount,'2. recordcount after first (empty)');
+    CheckEquals(0,RecNo,'2. recno after first (empty)');
+    CheckEquals(True,EOF and BOF, '1. Empty');
 
     last;
-    CheckEquals(0,RecordCount);
-    CheckEquals(0,RecNo);
+    CheckEquals(0,RecordCount,'3. recordcount after last (empty)');
+    CheckEquals(0,RecNo,'3. recordcount after last (empty)');
+    CheckEquals(True,EOF and BOF, '3. Empty');
 
     append;
-    CheckEquals(0,RecNo);
-    CheckEquals(0,RecordCount);
+    CheckEquals(0,RecNo,'4. recno after append (empty)');
+    CheckEquals(0,RecordCount,'4. recordcount after append (empty)');
+    CheckEquals(False, EOF and BOF, '4. Empty');
 
     first;
-    CheckEquals(0,RecNo);
-    CheckEquals(0,RecordCount);
+    CheckEquals(0,RecNo,'5. recno after first append (empty,append )');
+    CheckEquals(0,RecordCount,'5. recordcount after first (empty, append)');
+    CheckEquals(True,EOF and BOF, '5. Empty');
 
     append;
     FieldByName('id').AsInteger := 1;
-    CheckEquals(0,RecNo);
-    CheckEquals(0,RecordCount);
+    CheckEquals(0,RecNo,'6. recno after second append (empty,append)');
+    CheckEquals(0,RecordCount,'6. recordcount after second append (empty,append)');
+    CheckEquals(False ,EOF and BOF, '6. Empty');
 
     first;
-    CheckEquals(1,RecNo);
-    CheckEquals(1,RecordCount);
+    CheckEquals(1,RecNo,'7. recno after second append, first (1,append)');
+    CheckEquals(1,RecordCount,'7. recordcount after second append,first (1,append)');
+    CheckEquals(False ,EOF and BOF, '7. Empty');
 
     last;
-    CheckEquals(1,RecNo);
-    CheckEquals(1,RecordCount);
+    CheckEquals(1,RecNo,'8. recno after second append, last (1,append)');
+    CheckEquals(1,RecordCount,'8. recordcount after second append, last (1,append)');
 
     append;
-    FieldByName('id').AsInteger := 1;
-    CheckEquals(0,RecNo,'RecNo after 3rd Append');
-    CheckEquals(1,RecordCount);
+    FieldByName('id').AsInteger := 2;
+    CheckEquals(0,RecNo,'9. RecNo after 3rd Append');
+    CheckEquals(1,RecordCount,'9. Recordcount after 3rd Append');
+    post;
+
+    edit;
+    CheckEquals(2,RecNo,'RecNo after Edit');
+    CheckEquals(2,RecordCount);
 
     Close;
+
+    // Tests if RecordCount resets to 0 after dataset is closed
+    passed := false;
+    try
+      passed := RecordCount = 0;
+    except on E: Exception do
+      passed := E.classname = EDatabaseError.className
+    end;
+    if not passed then
+      CheckEquals(0,RecordCount,'RecordCount after Close');
     end;
 end;
 
@@ -669,9 +685,9 @@ end;
 procedure TTestDBBasics.TestDetectionNonMatchingDataset;
 var
   F: TField;
-  ds: tdataset;
+  ds: TDataSet;
 begin
-  // TDataset.Bindfields should detect problems when the underlying data does
+  // TDataset.BindFields should detect problems when the underlying data does
   // not reflect the fields of the dataset. This test is to check if this is
   // really done.
   ds := DBConnector.GetNDataset(true,6);
@@ -699,7 +715,7 @@ begin
     InsertRecord([152,'TestInsRec']);
     CheckEquals(152,fields[0].AsInteger);
     CheckEquals('TestInsRec',fields[1].AsString);
-    CheckTrue(state=dsBrowse);
+    CheckTrue(State=dsBrowse);
 
     // AppendRecord should append a record, further the same as InsertRecord
     AppendRecord([151,'TestInsRec']);
@@ -752,12 +768,12 @@ begin
     CheckEquals(1,FieldByName('id').AsInteger);
 
     next;
-    delete;
+    delete;           // id=2
 
     GotoBookmark(BM2);
     CheckEquals(3,FieldByName('id').AsInteger,'After #2 deleted');
     
-    delete;delete;
+    delete;delete;    // id=3,4
 
     GotoBookmark(BM3);
     CheckEquals(6,FieldByName('id').AsInteger);
@@ -2782,7 +2798,7 @@ procedure TTestDBBasics.TestCalculatedField;
 var ds   : TDataset;
     AFld1, AFld2, AFld3 : Tfield;
 begin
-  ds := DBConnector.GetNDataset(5);
+  ds := DBConnector.GetNDataset(True,5);
   with ds do
     begin
     AFld1 := TIntegerField.Create(ds);
@@ -2801,10 +2817,10 @@ begin
     CheckEquals(3,FieldCount);
     ds.OnCalcFields := TestcalculatedField_OnCalcfields;
     open;
-    CheckEquals(1,FieldByName('ID').asinteger);
-    CheckEquals(5,FieldByName('CALCFLD').asinteger);
+    CheckEquals(1, FieldByName('ID').AsInteger);
+    CheckEquals(5, FieldByName('CALCFLD').AsInteger);
     next;
-    CheckEquals(70000,FieldByName('CALCFLD').asinteger);
+    CheckEquals(70000,FieldByName('CALCFLD').AsInteger);
     next;
     CheckTrue(FieldByName('CALCFLD').IsNull, '#3 Null');
     next;

packages/fcl-db/tests/testdbexport.pas

@@ -517,7 +517,6 @@ begin
   ExportSettings:=TCSVFormatSettings.Create(true);
   try
     ExportSettings.FieldDelimiter:=';';
-    ExportSettings.QuoteStrings:=[qsAlways,qsSpace,qsDelimiter]; //quote everything we can
     ExportSettings.StringQuoteChar:='"'; //try explicit assignment
     ExportSettings.RowDelimiter:=#10; //Unix/Linux format
     ExportSettings.BooleanFalse:='onwaar'; //why not a Dutch output format?

packages/fcl-db/tests/testfieldtypes.pas

@@ -211,7 +211,7 @@ begin
     SQL.Add('select * from FPDEV2');
     Open;
     AssertEquals(1,FieldCount);
-    AssertTrue(CompareText('FT',fields[0].FieldName)=0);
+    AssertTrue(SameText('FT',Fields[0].FieldName));
     AssertEquals('DataSize', ADataSize, Fields[0].DataSize);
     AssertEquals('DataType', ord(ADatatype), ord(Fields[0].DataType));
     Close;
@@ -449,9 +449,10 @@ begin
     for i := 0 to testValuesCount-1 do
       begin
       AssertEquals(testValues[i], Fields[0].AsString);
+      AssertEquals('IsNull', False, Fields[0].IsNull); // '' is not NULL
       Next;
       end;
-    close;
+    Close;
     end;
 end;
 
@@ -1665,6 +1666,7 @@ begin
       else
         AssertTrue('no test for paramtype available',False);
       end;
+      AssertEquals('IsNull', False, FieldByName('FIELD1').IsNull);
       Next;
       end;
     AssertTrue('Expected IsNull', FieldByName('FIELD1').IsNull);

packages/fcl-db/tests/testspecifictbufdataset.pas

@@ -39,6 +39,7 @@ type
     procedure TestAutoIncField;
     procedure TestAutoIncFieldStreaming;
     procedure TestAutoIncFieldStreamingXML;
+    Procedure TestRecordCount;
   end;
 
 implementation
@@ -248,6 +249,22 @@ begin
   IntTestAutoIncFieldStreaming(true);
 end;
 
+procedure TTestSpecificTBufDataset.TestRecordCount;
+var
+  BDS:TBufDataSet;
+  
+begin
+  BDS:=TBufDataSet.Create(nil);
+  BDS.FieldDefs.Add('ID',ftLargeint);
+  BDS.CreateDataSet;
+  BDS.AppendRecord([1]);
+  BDS.AppendRecord([2]);
+  BDS.AppendRecord([3]);
+  BDS.Close;
+  AssertEquals('IsEmpty: ',True,BDS.IsEmpty);
+  AssertEquals('RecordCount: ',0,BDS.RecordCount);
+end;
+  
 initialization
 {$ifdef fpc}
 

packages/fcl-db/tests/testspecifictmemdataset.pas

@@ -10,7 +10,7 @@ interface
 
 uses
   Classes, SysUtils,
-  fpcunit, testregistry,
+  testregistry,
   ToolsUnit;
 
 type

packages/fcl-db/tests/testsqldb.pas

@@ -17,8 +17,8 @@ type
   { TSQLDBTestCase }
 
   TSQLDBTestCase = class(TTestCase)
-  private
-    function GetSQLDBConnector: TSQLDBConnector;
+    private
+      function GetSQLDBConnector: TSQLDBConnector;
     protected
       procedure SetUp; override;
       procedure TearDown; override;
@@ -46,13 +46,16 @@ type
     Procedure TestAutoApplyUpdatesDelete;
     Procedure TestCheckRowsAffected;
     Procedure TestAutoCommit;
-    Procedure TestRefreshSQL;
     Procedure TestGeneratedRefreshSQL;
     Procedure TestGeneratedRefreshSQL1Field;
     Procedure TestGeneratedRefreshSQLNoKey;
+    Procedure TestRefreshSQL;
     Procedure TestRefreshSQLMultipleRecords;
     Procedure TestRefreshSQLNoRecords;
     Procedure TestFetchAutoInc;
+    procedure TestSequence;
+    procedure TestReturningInsert;
+    procedure TestReturningUpdate;
   end;
 
   { TTestTSQLConnection }
@@ -86,7 +89,7 @@ implementation
 
 { TTestTSQLQuery }
 
-Procedure TTestTSQLQuery.Setup;
+procedure TTestTSQLQuery.Setup;
 begin
   inherited Setup;
   SQLDBConnector.Connection.Options:=[];
@@ -181,7 +184,7 @@ begin
   end;
 end;
 
-Procedure TTestTSQLQuery.TestKeepOpenOnCommit;
+procedure TTestTSQLQuery.TestKeepOpenOnCommit;
 var Q: TSQLQuery;
     I: Integer;
 begin
@@ -197,7 +200,7 @@ begin
 
     Q := SQLDBConnector.Query;
     Q.SQL.Text:='select * from FPDEV2';
-    Q.Options:=[sqoKeepOpenOnCommit];
+    Q.Options:=[sqoKeepOpenOnCommit,sqoRefreshUsingSelect];
     AssertEquals('PacketRecords forced to -1',-1,Q.PacketRecords);
     Q.Open;
     AssertEquals('Got all records',20,Q.RecordCount);
@@ -219,12 +222,12 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TrySetPacketRecords;
+procedure TTestTSQLQuery.TrySetPacketRecords;
 begin
   FMyQ.PacketRecords:=10;
 end;
 
-Procedure TTestTSQLQuery.TestKeepOpenOnCommitPacketRecords;
+procedure TTestTSQLQuery.TestKeepOpenOnCommitPacketRecords;
 begin
   with SQLDBConnector do
     begin
@@ -234,12 +237,12 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TrySetQueryOptions;
+procedure TTestTSQLQuery.TrySetQueryOptions;
 begin
   FMyQ.Options:=[sqoKeepOpenOnCommit];
 end;
 
-Procedure TTestTSQLQuery.TestCheckSettingsOnlyWhenInactive;
+procedure TTestTSQLQuery.TestCheckSettingsOnlyWhenInactive;
 begin
   // Check that we can only set QueryOptions when the query is inactive.
   with SQLDBConnector do
@@ -261,7 +264,7 @@ begin
   AssertTrue('Have modifications in after post',FMyq.UpdateStatus=usModified)
 end;
 
-Procedure TTestTSQLQuery.TestAutoApplyUpdatesPost;
+procedure TTestTSQLQuery.TestAutoApplyUpdatesPost;
 var Q: TSQLQuery;
     I: Integer;
 begin
@@ -296,7 +299,7 @@ begin
 
 end;
 
-Procedure TTestTSQLQuery.TestAutoApplyUpdatesDelete;
+procedure TTestTSQLQuery.TestAutoApplyUpdatesDelete;
 
 var Q: TSQLQuery;
     I: Integer;
@@ -328,13 +331,13 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.DoApplyUpdates;
+procedure TTestTSQLQuery.DoApplyUpdates;
 
 begin
   FMyQ.ApplyUpdates();
 end;
 
-Procedure TTestTSQLQuery.TestCheckRowsAffected;
+procedure TTestTSQLQuery.TestCheckRowsAffected;
 var Q: TSQLQuery;
     I: Integer;
 begin
@@ -359,7 +362,7 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TestAutoCommit;
+procedure TTestTSQLQuery.TestAutoCommit;
 var
   I : Integer;
 begin
@@ -389,42 +392,7 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TestRefreshSQL;
-var
-  Q: TSQLQuery;
-
-begin
-  with SQLDBConnector do
-    begin
-    ExecuteDirect('create table FPDEV2 (id integer not null primary key, a varchar(5) default ''abcde'', b integer default 1)');
-    if Transaction.Active then
-      Transaction.Commit;
-    end;
-  Q:=SQLDBConnector.Query;
-  Q.SQL.Text:='select * from FPDEV2';
-  Q.InsertSQL.Text:='insert into FPDEV2 (id) values (:id)';
-  Q.RefreshSQL.Text:='SELECT a,b FROM FPDEV2 WHERE (id=:id)';
-  Q.Open;
-  Q.Insert;  // #1 record
-  Q.FieldByName('id').AsInteger:=1;
-  Q.Post;
-  Q.Append;  // #2 record
-  Q.FieldByName('id').AsInteger:=2;
-  Q.Post;
-  AssertTrue('Field value has not been fetched after Post', Q.FieldByName('a').IsNull);
-  Q.ApplyUpdates(0);
-  // #2 record:
-  AssertEquals('Still on correct field', 2, Q.FieldByName('id').AsInteger);
-  AssertEquals('Field value has been fetched from the database', 'abcde', Q.FieldByName('a').AsString);
-  AssertEquals('Field value has been fetched from the database', 1, Q.FieldByName('b').AsInteger);
-  Q.Prior;
-  // #1 record:
-  AssertEquals('Still on correct field', 1, Q.FieldByName('id').AsInteger);
-  AssertEquals('Field value has been fetched from the database', 'abcde', Q.FieldByName('a').AsString);
-  AssertEquals('Field value has been fetched from the database', 1, Q.FieldByName('b').AsInteger);
-end;
-
-Procedure TTestTSQLQuery.TestGeneratedRefreshSQL;
+procedure TTestTSQLQuery.TestGeneratedRefreshSQL;
 
 var
   Q: TSQLQuery;
@@ -439,6 +407,7 @@ begin
   Q:=SQLDBConnector.Query;
   Q.SQL.Text:='select * from FPDEV2';
   Q.InsertSQL.Text:='insert into FPDEV2 (id) values (:id)';
+  Q.Options:=Q.Options+[sqoRefreshUsingSelect];
   Q.Open;
   With Q.FieldByName('id') do
     ProviderFlags:=ProviderFlags+[pfInKey];
@@ -456,7 +425,7 @@ begin
   AssertEquals('Field value has been fetched from the database ','fgh',Q.FieldByName('b').AsString);
 end;
 
-Procedure TTestTSQLQuery.TestGeneratedRefreshSQL1Field;
+procedure TTestTSQLQuery.TestGeneratedRefreshSQL1Field;
 var
   Q: TSQLQuery;
 
@@ -470,6 +439,7 @@ begin
   Q:=SQLDBConnector.Query;
   Q.SQL.Text:='select * from FPDEV2';
   Q.InsertSQL.Text:='insert into FPDEV2 (id) values (:id)';
+  Q.Options:=Q.Options+[sqoRefreshUsingSelect];
   Q.Open;
   With Q.FieldByName('id') do
     ProviderFlags:=ProviderFlags+[pfInKey];
@@ -485,7 +455,7 @@ begin
   AssertEquals('Field value b has NOT been fetched from the database ','',Q.FieldByName('b').AsString);
 end;
 
-Procedure TTestTSQLQuery.TestGeneratedRefreshSQLNoKey;
+procedure TTestTSQLQuery.TestGeneratedRefreshSQLNoKey;
 begin
   with SQLDBConnector do
     begin
@@ -496,6 +466,7 @@ begin
   FMyQ:=SQLDBConnector.Query;
   FMyQ.SQL.Text:='select * from FPDEV2';
   FMyQ.InsertSQL.Text:='insert into FPDEV2 (id) values (:id)';
+  FMyQ.Options:=FMyQ.Options+[sqoRefreshUsingSelect];
   FMyQ.Open;
   With FMyQ.FieldByName('id') do
     ProviderFlags:=ProviderFlags-[pfInKey];
@@ -507,7 +478,42 @@ begin
   AssertException('Cannot refresh without primary key',EUpdateError,@DoApplyUpdates);
 end;
 
-Procedure TTestTSQLQuery.TestRefreshSQLMultipleRecords;
+procedure TTestTSQLQuery.TestRefreshSQL;
+var
+  Q: TSQLQuery;
+
+begin
+  with SQLDBConnector do
+    begin
+    ExecuteDirect('create table FPDEV2 (id integer not null primary key, a varchar(5) default ''abcde'', b integer default 1)');
+    if Transaction.Active then
+      Transaction.Commit;
+    end;
+  Q:=SQLDBConnector.Query;
+  Q.SQL.Text:='select * from FPDEV2';
+  Q.InsertSQL.Text:='insert into FPDEV2 (id) values (:id)';
+  Q.RefreshSQL.Text:='SELECT a,b FROM FPDEV2 WHERE (id=:id)';
+  Q.Open;
+  Q.Insert;  // #1 record
+  Q.FieldByName('id').AsInteger:=1;
+  Q.Post;
+  Q.Append;  // #2 record
+  Q.FieldByName('id').AsInteger:=2;
+  Q.Post;
+  AssertTrue('Field value has not been fetched after Post', Q.FieldByName('a').IsNull);
+  Q.ApplyUpdates(0);
+  // #2 record:
+  AssertEquals('Still on correct field', 2, Q.FieldByName('id').AsInteger);
+  AssertEquals('Field value has been fetched from the database', 'abcde', Q.FieldByName('a').AsString);
+  AssertEquals('Field value has been fetched from the database', 1, Q.FieldByName('b').AsInteger);
+  Q.Prior;
+  // #1 record:
+  AssertEquals('Still on correct field', 1, Q.FieldByName('id').AsInteger);
+  AssertEquals('Field value has been fetched from the database', 'abcde', Q.FieldByName('a').AsString);
+  AssertEquals('Field value has been fetched from the database', 1, Q.FieldByName('b').AsInteger);
+end;
+
+procedure TTestTSQLQuery.TestRefreshSQLMultipleRecords;
 
 begin
   with SQLDBConnector do
@@ -534,7 +540,7 @@ begin
   AssertException('Multiple records returned by RefreshSQL gives an error',EUpdateError,@DoApplyUpdates);
 end;
 
-Procedure TTestTSQLQuery.TestRefreshSQLNoRecords;
+procedure TTestTSQLQuery.TestRefreshSQLNoRecords;
 begin
   with SQLDBConnector do
     begin
@@ -560,14 +566,12 @@ begin
   AssertException('No records returned by RefreshSQL gives an error',EUpdateError,@DoApplyUpdates);
 end;
 
-Procedure TTestTSQLQuery.TestFetchAutoInc;
+procedure TTestTSQLQuery.TestFetchAutoInc;
 var datatype: string;
     id: largeint;
 begin
   with SQLDBConnector do
     begin
-    if not (sqLastInsertID in Connection.ConnOptions) then
-      Ignore(STestNotApplicable);
     case SQLServerType of
       ssMySQL:
         datatype := 'integer auto_increment';
@@ -604,6 +608,119 @@ begin
     end;
 end;
 
+procedure TTestTSQLQuery.TestSequence;
+var SequenceNames : TStringList;
+begin
+  case SQLServerType of
+    ssFirebird:
+      SQLDBConnector.ExecuteDirect('create sequence FPDEV_SEQ1');
+    ssMSSQL, ssOracle, ssPostgreSQL:
+      SQLDBConnector.ExecuteDirect('create sequence FPDEV_SEQ1 MINVALUE 1');
+    else
+      Ignore(STestNotApplicable);
+  end;
+  SQLDBConnector.ExecuteDirect('create table FPDEV2 (id integer)');
+  SQLDBConnector.CommitDDL;
+
+  with SQLDBConnector.Query do
+    begin
+    SQL.Text := 'select * from FPDEV2';
+    Sequence.FieldName:='id';
+    Sequence.SequenceName:='FPDEV_SEQ1';
+    Open;
+    // default is get next value on new record
+    Append;
+    AssertEquals(1, FieldByName('id').AsInteger);
+
+    Sequence.ApplyEvent:=saeOnPost;
+    Append;
+    AssertTrue('Field ID must be null after Append', FieldByName('id').IsNull);
+    Post;
+    AssertEquals(2, FieldByName('id').AsInteger);
+    end;
+
+  // test GetSequenceNames
+  SequenceNames := TStringList.Create;
+  try
+    SQLDBConnector.Connection.GetSequenceNames(SequenceNames);
+    AssertTrue(SequenceNames.IndexOf('FPDEV_SEQ1') >= 0);
+  finally
+    SequenceNames.Free;
+  end;
+
+  SQLDBConnector.ExecuteDirect('drop sequence FPDEV_SEQ1');
+  SQLDBConnector.CommitDDL;
+end;
+
+procedure TTestTSQLQuery.TestReturningInsert;
+
+begin
+  with SQLDBConnector do
+    begin
+    if not (sqSupportReturning in Connection.ConnOptions) then
+      Ignore(STestNotApplicable);
+    ExecuteDirect('create table FPDEV2 (id integer not null, a varchar(10) default ''abcde'', b varchar(5) default ''fgh'', constraint PK_FPDEV2 primary key(id))');
+    if Transaction.Active then
+      Transaction.Commit;
+    ExecuteDirect('insert into FPDEV2 (id) values (123)');
+    if Transaction.Active then
+      Transaction.Commit;
+    end;
+  FMyQ:=SQLDBConnector.Query;
+  FMyQ.SQL.Text:='select * from FPDEV2';
+//  FMyQ.InsertSQL.Text:='insert into FPDEV2 (id) values (:id)';
+  FMyQ.Open;
+  With FMyQ.FieldByName('id') do
+    ProviderFlags:=ProviderFlags+[pfInKey];
+  With FMyQ.FieldByName('a') do
+    ProviderFlags:=ProviderFlags+[pfRefreshOnInsert];
+  With FMyQ.FieldByName('b') do
+    ProviderFlags:=[];
+  FMyQ.Insert;
+  FMyQ.FieldByName('id').AsInteger:=1;
+  FMyQ.Post;
+  FMyQ.ApplyUpdates;
+  AssertEquals('a updated','abcde',FMyQ.FieldByName('a').AsString);
+  AssertEquals('b not updated','',FMyQ.FieldByName('b').AsString);
+end;
+
+procedure TTestTSQLQuery.TestReturningUpdate;
+
+begin
+  with SQLDBConnector do
+    begin
+    if not (sqSupportReturning in Connection.ConnOptions) then
+      Ignore(STestNotApplicable);
+    ExecuteDirect('create table FPDEV2 (id integer not null, a varchar(10) default ''abcde'', b varchar(5) default ''fgh'', constraint PK_FPDEV2 primary key(id))');
+    CommitDDL;
+    ExecuteDirect('insert into FPDEV2 (id) values (1)');
+    ExecuteDirect('insert into FPDEV2 (id) values (2)');
+    end;
+  FMyQ:=SQLDBConnector.Query;
+  FMyQ.SQL.Text:='select * from FPDEV2';
+  FMyQ.Open;
+  With FMyQ.FieldByName('id') do
+    ProviderFlags:=ProviderFlags+[pfInKey];
+  With FMyQ.FieldByName('b') do
+    ProviderFlags:=[pfRefreshOnUpdate];  // Do not update, just fetch new value
+  SQLDBConnector.ExecuteDirect('update FPDEV2 set b=''b1'' where id=1');
+  SQLDBConnector.ExecuteDirect('update FPDEV2 set b=''b2'' where id=2');
+  FMyQ.Edit;
+  FMyQ.FieldByName('a').AsString:='a1';
+  FMyQ.Post;  // #1 record
+  FMyQ.Next;
+  FMyQ.Edit;
+  FMyQ.FieldByName('a').AsString:='a2';
+  FMyQ.Post;  // #2 record
+  FMyQ.ApplyUpdates;
+  FMyQ.First;
+  AssertEquals('#1.a updated', 'a1', FMyQ.FieldByName('a').AsString);
+  AssertEquals('#1.b updated', 'b1', FMyQ.FieldByName('b').AsString);
+  FMyQ.Next;
+  AssertEquals('#2.a updated', 'a2', FMyQ.FieldByName('a').AsString);
+  AssertEquals('#2.b updated', 'b2', FMyQ.FieldByName('b').AsString);
+end;
+
 
 { TTestTSQLConnection }
 
@@ -837,7 +954,7 @@ end;
 
 function TSQLDBTestCase.GetSQLDBConnector: TSQLDBConnector;
 begin
-  Result:=DBConnector as TSQLDBConnector;
+  Result := DBConnector as TSQLDBConnector;
 end;
 
 procedure TSQLDBTestCase.SetUp;

packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc

@@ -21,7 +21,6 @@
     class procedure CheckNotNull(obj: IUnknown; msg: string = ''); overload; virtual;
     class procedure CheckIs(obj :TObject; pClass: TClass; msg: string = ''); overload;
     class procedure CheckSame(expected, actual: TObject; msg: string = ''); overload;
-    class procedure FailNotEquals(expected, actual: string; msg: string = ''; errorAddr: Pointer = nil); virtual;
     class procedure CheckTrue(condition: Boolean; msg: string = '');
     class procedure CheckFalse(condition: Boolean; msg: string = '');
     class procedure CheckException(AMethod: TRunMethod; AExceptionClass: ExceptClass; msg: string = '');
@@ -153,12 +152,6 @@ begin
    AssertSame(msg, expected, actual);
 end;
 
-class procedure TAssert.FailNotEquals(expected, actual: string; msg: string;
-  errorAddr: Pointer);
-begin
-  Fail(msg + ComparisonMsg(Expected, Actual));
-end;
-
 class procedure TAssert.CheckTrue(condition: Boolean; msg: string);
 begin
   if (not condition) then
@@ -181,9 +174,9 @@ class function TAssert.EqualsErrorMessage(const expected, actual: string;
     const ErrorMsg: string): string;
 begin
   if (ErrorMsg <> '') then
-    Result := Format(sMsgActualEqualsExpFmt, [ErrorMsg + ', ', expected, actual])
+    Result := Format(sExpectedButWasAndMessageFmt, [ErrorMsg + ', ', expected, actual])
   else
-    Result := Format(sActualEqualsExpFmt, [expected, actual])
+    Result := Format(sExpectedButWasFmt, [expected, actual])
 end;
 
 class function TAssert.NotEqualsErrorMessage(const expected, actual: string;

packages/fcl-fpcunit/src/consoletestrunner.pas

@@ -73,9 +73,9 @@ uses testdecorator;
 
 const
   ShortOpts = 'alhp';
-  DefaultLongOpts: array[1..9] of string =
+  DefaultLongOpts: array[1..11] of string =
      ('all', 'list', 'progress', 'help', 'skiptiming',
-      'suite:', 'format:', 'file:', 'stylesheet:');
+      'suite:', 'format:', 'file:', 'stylesheet:','sparse','no-addresses');
 
   { TProgressWriter }
 type
@@ -154,6 +154,8 @@ begin
     end;
   end;
   Result.SkipTiming:=HasOption('skiptiming');
+  Result.Sparse:=HasOption('sparse');
+  Result.SkipAddressInfo:=HasOption('no-addresses');
 end;
 
 procedure TTestRunner.DoTestRun(ATest: TTest);
@@ -213,6 +215,8 @@ begin
     writeln('  --format=plain            output as plain ASCII source');
     writeln('  --format=xml              output as XML source (default)');
     writeln('  --skiptiming              Do not output timings (useful for diffs of testruns)');
+    writeln('  --sparse                  Produce Less output (errors/failures only)');
+    writeln('  --no-addresses            Do not display address info');
     writeln('  --stylesheet=<reference>   add stylesheet reference');
     writeln('  --file=<filename>         output results to file');
     writeln;
@@ -280,6 +284,7 @@ Type
   { TDecoratorTestSuite }
 
   TDecoratorTestSuite = Class(TTestSuite)
+  public
     Procedure  FreeDecorators(T : TTest);
     Destructor Destroy; override;
   end;

packages/fcl-fpcunit/src/fpcunit.pp

@@ -79,16 +79,21 @@ type
 
   TAssert = class(TTest)
   public
-    class procedure Fail(const AMessage: string);
-    class procedure Fail(const AFmt: string; Args : Array of const);
-    class procedure AssertTrue(const AMessage: string; ACondition: boolean); overload;
+    class procedure Fail(const AMessage: string; AErrorAddrs: Pointer = nil);
+    class procedure Fail(const AFmt: string; Args : Array of const;  AErrorAddrs: Pointer = nil);
+    class procedure FailEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
+    class procedure FailNotEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
+
+    class procedure AssertTrue(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil); overload;
     class procedure AssertTrue(ACondition: boolean); overload;
-    class procedure AssertFalse(const AMessage: string; ACondition: boolean); overload;
+    class procedure AssertFalse(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil); overload;
     class procedure AssertFalse(ACondition: boolean); overload;
     class procedure AssertEquals(const AMessage: string; Expected, Actual: string); overload;
     class procedure AssertEquals(Expected, Actual: string); overload;
+    {$IFDEF UNICODE}
     class procedure AssertEquals(const AMessage: string; Expected, Actual: UnicodeString); overload;
     class procedure AssertEquals(Expected, Actual: UnicodeString); overload;
+    {$ENDIF}
     class procedure AssertEquals(const AMessage: string; Expected, Actual: integer); overload;
     class procedure AssertEquals(Expected, Actual: integer); overload;
     class procedure AssertEquals(const AMessage: string; Expected, Actual: int64); overload;
@@ -125,8 +130,8 @@ type
     class procedure AssertNull(APointer: Pointer); overload;
     class procedure AssertNotNull(const AMessage, AString: string); overload;
     class procedure AssertNotNull(const AString: string); overload;
-    class procedure AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TRunMethod); overload;
-    class procedure AssertException(AExceptionClass: ExceptClass; AMethod: TRunMethod); overload;
+    class procedure AssertException(const AMessage: string; AExceptionClass: ExceptClass; AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0; AErrorAddr : Pointer = Nil); overload;
+    class procedure AssertException(AExceptionClass: ExceptClass; AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0); overload;
 
     {$IFDEF DUnit}
       {$I DUnitCompatibleInterface.inc}
@@ -142,15 +147,17 @@ type
     FRaisedExceptionClass: TClass;
     FRaisedExceptionMessage: string;
     FSourceUnitName: string;
+    FThrownExceptionAddress: Pointer;
     FTestLastStep: TTestStep;
     function GetAsString: string;
     function GetExceptionMessage: string;
     function GetIsFailure: boolean;
     function GetIsIgnoredTest: boolean;
     function GetExceptionClassName: string;
+    function GetLocationInfo: string;
     procedure SetTestLastStep(const Value: TTestStep);
   public
-    constructor CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep);
+    constructor CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep; ThrownExceptionAddrs: pointer = nil);
     property ExceptionClass: TClass read FRaisedExceptionClass;
   published
     property AsString: string read GetAsString;
@@ -160,6 +167,7 @@ type
     property ExceptionClassName: string read GetExceptionClassName;
     property SourceUnitName: string read FSourceUnitName write FSourceUnitName;
     property LineNumber: longint read FLineNumber write FLineNumber;
+    property LocationInfo: string read GetLocationInfo;
     property FailedMethodName: string read FFailedMethodName write FFailedMethodName;
     property TestLastStep: TTestStep read FTestLastStep write SetTestLastStep;
   end;
@@ -174,11 +182,18 @@ type
     procedure EndTestSuite(ATestSuite: TTestSuite);
   end;
 
+  { TTestCase }
+
   TTestCase = class(TAssert)
   private
     FName: string;
     FTestSuiteName: string;
     FEnableIgnores: boolean;
+    FExpectedExceptionFailMessage : String;
+    FExpectedException : TClass;
+    FExpectedExceptionMessage: String;
+    FExpectedExceptionContext: Integer;
+    FExpectedExceptionCaller : Pointer;
   protected
     function CreateResult: TTestResult; virtual;
     procedure SetUp; virtual;
@@ -195,11 +210,17 @@ type
     constructor Create; virtual;
     constructor CreateWith(const ATestName: string; const ATestSuiteName: string); virtual;
     constructor CreateWithName(const AName: string); virtual;
+    procedure ExpectException(AExceptionClass: TClass; AExceptionMessage: string=''; AExceptionHelpContext: Integer=0);
+    procedure ExpectException(const Msg: String; AExceptionClass: TClass; AExceptionMessage: string=''; AExceptionHelpContext: Integer=0);
     function CountTestCases: integer; override;
     function CreateResultAndRun: TTestResult; virtual;
     procedure Run(AResult: TTestResult); override;
     function AsString: string;
     property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
+    Property ExpectedExceptionFailMessage  : String Read FExpectedExceptionFailMessage;
+    Property ExpectedException : TClass Read FExpectedException;
+    Property ExpectedExceptionMessage : String Read FExpectedExceptionMessage;
+    Property ExpectedExceptionContext: Integer Read FExpectedExceptionContext;
   published
     property TestName: string read GetTestName write SetTestName;
   end;
@@ -261,9 +282,8 @@ type
     destructor Destroy; override;
     procedure ClearErrorLists;
     procedure StartTest(ATest: TTest);
-    procedure AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList);
-    procedure AddError(ATest: TTest; E: Exception; AUnitName: string;
-      AFailedMethodName: string; ALineNumber: longint);
+    procedure AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList; AThrownExceptionAdrs: Pointer);
+    procedure AddError(ATest: TTest; E: Exception; AThrownExceptionAdrs: Pointer);
     procedure EndTest(ATest: TTest);
     procedure AddListener(AListener: ITestListener);
     procedure RemoveListener(AListener: ITestListener);
@@ -288,8 +308,14 @@ type
     property StartingTime: TDateTime read FStartingTime;
   end;
 
-  function ComparisonMsg(const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string;
-  function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string;
+  function ComparisonMsg(const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string; overload;
+  {$IFDEF UNICODE}
+  function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string; overload;
+  {$ENDIF}
+  function ComparisonMsg(const aMsg: string; const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string; overload;
+
+  // Made public for 3rd party developers extending TTestCase with new AssertXXX methods
+  function CallerAddr: Pointer;
 
   
 Resourcestring
@@ -298,6 +324,8 @@ Resourcestring
   SCompareNotEqual = ' expected: not equal to <%s> but was: <%s>';
   SExpectedNotSame = 'expected not same';
   SExceptionCompare = 'Exception %s expected but %s was raised';
+  SExceptionMessageCompare = 'Exception raised but exception property Message differs: ';
+  SExceptionHelpContextCompare = 'Exception raised but exception property HelpContext differs: ';
   SMethodNotFound = 'Method <%s> not found';
   SNoValidInheritance = ' does not inherit from TTestCase';
   SNoValidTests = 'No valid tests found in ';
@@ -311,8 +339,6 @@ uses
 Const
   sExpectedButWasFmt = 'Expected:' + LineEnding + '"%s"' + LineEnding + 'But was:' + LineEnding + '"%s"';
   sExpectedButWasAndMessageFmt = '%s' + LineEnding + sExpectedButWasFmt;
-  sMsgActualEqualsExpFmt = '%s' + LineEnding + 'Expected ' + LineEnding + '< %s > ' + LineEnding + 'equals actual ' + LineEnding + '< %s >';
-  sActualEqualsExpFmt = 'Expected ' + LineEnding + '< %s > ' + LineEnding + 'equals actual ' + LineEnding + '< %s >';
 
 
 { This lets us use a single include file for both the Interface and
@@ -321,6 +347,48 @@ Const
 {$define read_implementation}
 
 
+function CallerAddr: Pointer;
+
+Var
+  bp,pcaddr : pointer;
+  
+begin
+  Result:=Nil;
+  bp:=get_frame;
+  pcaddr:=get_pc_addr;
+  get_caller_stackinfo(bp,pcaddr);
+  if bp<>Nil then
+    get_caller_stackinfo(bp,pcaddr);
+  result:=pcaddr;
+end;
+
+function AddrsToStr(Addrs: Pointer): string;
+begin
+  if PtrUInt(Addrs) > 0 then
+    Result := '$'+Format('%p', [Addrs])
+  else
+    Result := 'n/a';
+end;
+
+
+function PointerToLocationInfo(Addrs: Pointer): string;
+
+begin
+  Result := BackTraceStrFunc(Addrs);
+  if Trim(Result) = '' then
+    Result := AddrsToStr(Addrs) + '  <no map file>';
+end;
+
+// Get the ClassName of C
+function GetN(C : TClass) : string;
+begin
+  if C=Nil then
+    Result:='<NIL>'
+  else
+    Result:=C.ClassName;
+end;
+
+
 type
 
   TTestWarning = class(TTestCase)
@@ -346,7 +414,7 @@ begin
     Result := format(SCompareNotEqual, [aExpected, aActual]);
 end;
 
-
+{$IFDEF UNICODE}
 function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string;
 // aCheckEqual=false gives the error message if the test does *not* expect the results to be the same.
 begin
@@ -355,6 +423,12 @@ begin
   else {check unequal requires opposite error message}
     Result := format(UnicodeString(SCompareNotEqual), [aExpected, aActual]);
 end;
+{$ENDIF}
+
+function ComparisonMsg(const aMsg: string; const aExpected: string; const aActual: string; const aCheckEqual: boolean): string;
+begin
+  Result := '"' + aMsg + '"' + ComparisonMsg(aExpected, aActual, aCheckEqual);
+end;
 
 
 constructor EAssertionFailedError.Create;
@@ -369,13 +443,14 @@ begin
 end;
 
 
-constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep);
+constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep; ThrownExceptionAddrs: pointer);
 begin
   inherited Create;
   FTestName := ATest.GetTestName;
   FTestSuiteName := ATest.GetTestSuiteName;
   FRaisedExceptionClass := E.ClassType;
   FRaisedExceptionMessage := E.Message;
+  FThrownExceptionAddress := ThrownExceptionAddrs;
   FTestLastStep := LastStep;
 end;
 
@@ -400,6 +475,11 @@ begin
     Result := '<NIL>'
 end;
 
+function TTestFailure.GetLocationInfo: string;
+begin
+  Result := PointerToLocationInfo(FThrownExceptionAddress);
+end;
+
 
 function TTestFailure.GetExceptionMessage: string;
 begin
@@ -463,65 +543,86 @@ end;
 
 { TAssert }
 
-class procedure TAssert.Fail(const AMessage: string);
+class procedure TAssert.Fail(const AMessage: string; AErrorAddrs: Pointer);
 begin
-  raise EAssertionFailedError.Create(AMessage);
+  if AErrorAddrs = nil then
+    raise EAssertionFailedError.Create(AMessage) at CallerAddr
+  else
+    raise EAssertionFailedError.Create(AMessage) at AErrorAddrs;
 end;
 
-class procedure TAssert.Fail(const AFmt: string; Args: array of const);
+class procedure TAssert.Fail(const AFmt: string; Args: array of const; AErrorAddrs: Pointer = nil);
 begin
-  raise EAssertionFailedError.CreateFmt(AFmt,Args);
+  if AErrorAddrs = nil then
+    raise EAssertionFailedError.CreateFmt(AFmt,Args) at CallerAddr
+  else    
+    raise EAssertionFailedError.CreateFmt(AFmt,Args) at AErrorAddrs;
 end;
 
+class procedure TAssert.FailEquals(const expected, actual: string; const ErrorMsg: string; AErrorAddrs: Pointer);
+begin
+  Fail(EqualsErrorMessage(expected, actual, ErrorMsg), AErrorAddrs);
+end;
+
+class procedure TAssert.FailNotEquals(const expected, actual: string; const ErrorMsg: string; AErrorAddrs: Pointer);
+begin
+  Fail(NotEqualsErrorMessage(expected, actual, ErrorMsg), AErrorAddrs);
+end;
 
-class procedure TAssert.AssertTrue(const AMessage: string; ACondition: boolean);
+class procedure TAssert.AssertTrue(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil);
 begin
+  if AErrorAddrs=Nil then
+    AErrorAddrs:=CallerAddr;
   if (not ACondition) then
-    Fail(AMessage);
+    Fail(AMessage,AErrorAddrs);
 end;
 
 
 class procedure TAssert.AssertTrue(ACondition: boolean);
+
 begin
-  AssertTrue('', ACondition);
+  AssertTrue('', ACondition,CallerAddr);
 end;
 
 
-class procedure TAssert.AssertFalse(const AMessage: string; ACondition: boolean
+class procedure TAssert.AssertFalse(const AMessage: string; ACondition: boolean; AErrorAddrs: Pointer = nil
   );
 begin
-  AssertTrue(AMessage, not ACondition);
+  if AErrorAddrs=Nil then
+    AErrorAddrs:=CallerAddr;
+  AssertTrue(AMessage, not ACondition,AErrorAddrs);
 end;
 
 
 class procedure TAssert.AssertFalse(ACondition: boolean);
 begin
-  AssertFalse('', ACondition);
+  AssertFalse('', ACondition,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: string);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), AnsiCompareStr(Expected, Actual) = 0);
+  AssertTrue(ComparisonMsg(AMessage ,Expected, Actual), AnsiCompareStr(Expected, Actual) = 0,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: string);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(Expected, Actual), AnsiCompareStr(Expected, Actual) = 0,CallerAddr);
 end;
 
-class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: Unicodestring);
+{$IFDEF UNICODE}
+class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: UnicodeString);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), (Expected=Actual));
+  AssertTrue(ComparisonMsg(AMessage,Expected, Actual), (Expected=Actual),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: UnicodeString);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(Expected, Actual), (Expected=Actual),CallerAddr);
 end;
-
+{$ENDIF}
 
 class procedure TAssert.AssertNotNull(const AString: string);
 begin
@@ -531,254 +632,256 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: integer);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: integer);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: int64);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: int64);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: currency);
 begin
-  AssertTrue(AMessage + ComparisonMsg(FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: currency);
 begin
-   AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual, Delta: double);
 begin
-  AssertTrue(AMessage + ComparisonMsg(FloatToStr(Expected),FloatToStr(Actual)),
-    (Abs(Expected - Actual) <= Delta));
+  AssertTrue(ComparisonMsg(AMessage,FloatToStr(Expected),FloatToStr(Actual)),
+    (Abs(Expected - Actual) <= Delta),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual, Delta: double);
 begin
-  AssertEquals('', Expected, Actual, Delta);
+  AssertTrue(ComparisonMsg(FloatToStr(Expected),FloatToStr(Actual)),
+    (Abs(Expected - Actual) <= Delta),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(const AMessage, AString: string);
 begin
-  AssertTrue(AMessage, AString <> '');
+  AssertTrue(AMessage, AString <> '',CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: boolean);
 begin
-  AssertTrue(AMessage + ComparisonMsg(BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: boolean);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: char);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,Expected, Actual), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: char);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(Expected, Actual), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: TClass);
 
-  Function GetN(C : TClass) : string;
-  begin
-    if C=Nil then
-      Result:='<NIL>'
-    else
-      Result:=C.ClassName;
-  end;
-
 begin
-  AssertTrue(AMessage + ComparisonMsg(GetN(Expected), GetN(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,GetN(Expected), GetN(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertEquals(Expected, Actual: TClass);
 begin
-  AssertEquals('', Expected, Actual);
+  AssertTrue(ComparisonMsg(GetN(Expected), GetN(Actual)), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: TObject);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
-    Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(Expected, Actual: TObject);
 begin
-  AssertSame('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: Pointer);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
-    Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertSame(Expected, Actual: Pointer);
 begin
-  AssertSame('', Expected, Actual);
+  AssertTrue(ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))), Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotSame(const AMessage: string; Expected, Actual: TObject);
 begin
-  AssertFalse(SExpectedNotSame, Expected = Actual);
+  AssertFalse('"' + aMessage + '"' + SExpectedNotSame, Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotSame(Expected, Actual: TObject);
 begin
-  AssertNotSame('', Expected, Actual);
+  AssertFalse(SExpectedNotSame, Expected = Actual);
 end;
 
 
 class procedure TAssert.AssertNotSame(const AMessage: string; Expected, Actual: Pointer);
 begin
-  AssertFalse(SExpectedNotSame, Expected = Actual);
+  AssertFalse('"' + aMessage + '"' + SExpectedNotSame, Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotSame(Expected, Actual: Pointer);
 begin
-  AssertNotSame('', Expected, Actual);
+  AssertFalse(SExpectedNotSame, Expected = Actual,CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(const AMessage: string; AObject: TObject);
 begin
-  AssertTrue(AMessage, (AObject <> nil));
+  AssertTrue(AMessage, (AObject <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(AObject: TObject);
 begin
-  AssertNotNull('', AObject);
+  AssertTrue('',(AObject <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNullIntf(const AMessage: string; AInterface: IInterface);
 begin
-  AssertTrue(AMessage, (AInterface <> nil));
+  AssertTrue(AMessage, (AInterface <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNullIntf(AInterface: IInterface);
 begin
-  AssertNotNull('', AInterface);
+  AssertTrue('', (AInterface <> nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(const AMessage: string; APointer: Pointer);
 begin
-  AssertTrue(AMessage, (APointer <> nil));
+  AssertTrue(AMessage, (APointer <> nil),callerAddr);
 end;
 
 
 class procedure TAssert.AssertNotNull(APointer: Pointer);
 begin
-  AssertNotNull('', APointer);
+  AssertTrue('', (APointer <> nil),callerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(const AMessage: string; AObject: TObject);
 begin
-  AssertTrue(AMessage, (AObject = nil));
+  AssertTrue(AMessage, (AObject = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(AObject: TObject);
 begin
-  AssertNull('', AObject);
+  AssertTrue('',(AObject = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNullIntf(const AMessage: string; AInterface: IInterface);
 begin
-  AssertTrue(AMessage, (AInterface = nil));
+  AssertTrue(AMessage, (AInterface = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNullIntf(AInterface: IInterface);
 begin
-  AssertNull('', AInterface);
+  AssertTrue('', (AInterface = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(const AMessage: string; APointer: Pointer);
 begin
-  AssertTrue(AMessage, (APointer = nil));
+  AssertTrue(AMessage, (APointer = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertNull(APointer: Pointer);
 begin
-  AssertNull('', APointer);
+  AssertTrue('', (APointer = nil),CallerAddr);
 end;
 
 
 class procedure TAssert.AssertException(const AMessage: string; AExceptionClass: ExceptClass;
-  AMethod: TRunMethod);
+  AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0; AErrorAddr : Pointer = Nil);
+
+  Function MisMatch (AClassName : String) : String;
+
+  begin
+    Result:=Format(SExceptionCompare,[AExceptionClass.ClassName, AClassName])
+  end;
+
 var
-  Passed : Boolean;
-  ExceptionName: string;
+  FailMsg : string;
 begin
-  Passed := False;
+  If AErrorAddr=Nil then
+    AErrorAddr:=CallerAddr;
+  FailMsg:='';
   try
     AMethod;
-    ExceptionName:=SNoException;
+    FailMsg:=MisMatch(SNoException);
   except
     on E: Exception do
-    begin
-      ExceptionName := E.ClassName;
-      if E.ClassType.InheritsFrom(AExceptionClass) then
       begin
-        Passed := AExceptionClass.ClassName = E.ClassName;
+      if Not E.ClassType.InheritsFrom(AExceptionClass) then
+        FailMsg:=MisMatch(E.ClassName)
+      else if not (AExceptionClass.ClassName = E.ClassName) then
+        FailMsg:=MisMatch(E.ClassName)
+      else if (AExceptionMessage<>'') and (AExceptionMessage<>E.Message) then
+        FailMsg:=ComparisonMsg(SExceptionMessageCompare,AExceptionMessage,E.Message)
+      else if (AExceptionContext<>0) and (AExceptionContext<>E.HelpContext) then
+        FailMsg:=ComparisonMsg(SExceptionHelpContextCompare,IntToStr(AExceptionContext),IntToStr(E.HelpContext))
       end;
-    end;
   end;
-  AssertTrue(Format(SExceptionCompare, [AExceptionClass.ClassName, ExceptionName])+ ': ' + AMessage, Passed);
+  AssertTrue(AMessage + FailMsg, FailMsg='', AErrorAddr);
 end;
 
 
 class procedure TAssert.AssertException(AExceptionClass: ExceptClass;
-  AMethod: TRunMethod);
+  AMethod: TRunMethod;AExceptionMessage : String = ''; AExceptionContext : Integer = 0);
 begin
-  AssertException('', AExceptionClass, AMethod);
+  AssertException('', AExceptionClass, AMethod, AExceptionMessage, AExceptionContext, CallerAddr);
 end;
 
 
@@ -898,6 +1001,8 @@ var
   m: TMethod;
   RunMethod: TRunMethod;
   pMethod : Pointer;
+  FailMessage : String;
+
 begin
   AssertNotNull('name of the test not assigned', FName);
   pMethod := Self.MethodAddress(FName);
@@ -906,7 +1011,33 @@ begin
     m.Code := pMethod;
     m.Data := self;
     RunMethod := TRunMethod(m);
-    RunMethod;
+    ExpectException('',Nil,'',0);
+    try
+      FailMessage:='';
+      RunMethod;
+      if (FExpectedException<>Nil) then
+        FailMessage:=Format(SExceptionCompare, [FExpectedException.ClassName, SNoException])
+    except
+      On E : Exception do
+        begin
+        if FExpectedException=Nil then
+          Raise;
+        If not (E is FExpectedException) then
+          FailMessage:=Format(SExceptionCompare, [FExpectedException.ClassName, E.ClassName]);
+        if (FExpectedExceptionMessage<>'') then
+          if (FExpectedExceptionMessage<>E.Message) then
+            FailMessage:=Format(SExceptionmessageCompare+SCompare, [FExpectedExceptionMessage,E.Message]);
+        if (FExpectedExceptionContext<>0) then
+          if (FExpectedExceptionContext<>E.HelpContext) then
+            FailMessage:=Format(SExceptionHelpContextCompare+SCompare, [IntToStr(FExpectedExceptionContext),IntToStr(E.HelpContext)])
+        end;
+    end;
+    if (FailMessage<>'') then
+      begin
+      if (FExpectedExceptionFailMessage<>'') then
+        FailMessage:=' : '+FailMessage;
+      Fail(FExpectedExceptionFailMessage+FailMessage,FExpectedExceptionCaller);
+      end;
   end
   else
     begin
@@ -1057,6 +1188,26 @@ begin
   end;
 end;
 
+procedure TTestCase.ExpectException(const Msg: String;
+  AExceptionClass: TClass; AExceptionMessage: string = '';
+  AExceptionHelpContext: Integer =0 );
+begin
+  FExpectedExceptionFailMessage:=Msg;
+  FExpectedException:=AExceptionClass;
+  FExpectedExceptionMessage:=AExceptionMessage;
+  FExpectedExceptionContext:=AExceptionHelpContext;
+  FExpectedExceptionCaller:=CallerAddr;
+end;
+
+procedure TTestCase.ExpectException(AExceptionClass: TClass;
+  AExceptionMessage: string = ''; AExceptionHelpContext: Integer = 0);
+begin
+  FExpectedExceptionFailMessage:='';
+  FExpectedException:=AExceptionClass;
+  FExpectedExceptionMessage:=AExceptionMessage;
+  FExpectedExceptionContext:=AExceptionHelpContext;
+  FExpectedExceptionCaller:=CallerAddr;
+end;
 
 procedure TTestSuite.Run(AResult: TTestResult);
 var
@@ -1174,13 +1325,13 @@ begin
 end;
 
 
-procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList);
+procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList; AThrownExceptionAdrs: Pointer);
 var
   i: integer;
   f: TTestFailure;
 begin
   //lock mutex
-  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
+  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep, AThrownExceptionAdrs);
   aFailureList.Add(f);
   for i := 0 to FListeners.Count - 1 do
     ITestListener(FListeners[i]).AddFailure(ATest, f);
@@ -1188,17 +1339,13 @@ begin
 end;
 
 
-procedure TTestResult.AddError(ATest: TTest; E: Exception;
-  AUnitName: string; AFailedMethodName: string; ALineNumber: longint);
+procedure TTestResult.AddError(ATest: TTest; E: Exception; AThrownExceptionAdrs: Pointer);
 var
   i: integer;
   f: TTestFailure;
 begin
   //lock mutex
-  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
-  f.SourceUnitName := AUnitName;
-  f.FailedMethodName := AFailedMethodName;
-  f.LineNumber := ALineNumber;
+  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep, AThrownExceptionAdrs);
   FErrors.Add(f);
   for i := 0 to FListeners.Count - 1 do
     ITestListener(FListeners[i]).AddError(ATest, f);
@@ -1233,26 +1380,17 @@ end;
 
 
 procedure TTestResult.RunProtected(ATestCase: TTest; protect: TProtect);
-var
-  func, source: shortstring;
-  line: longint;
 begin
-  func := '';
-  source := '';
-  line := 0;
   try
     protect(ATestCase, Self);
   except
     on E: EIgnoredTest do
-      AddFailure(ATestCase, E, FIgnoredTests);
+      AddFailure(ATestCase, E, FIgnoredTests, ExceptAddr);
     on E: EAssertionFailedError do
-      AddFailure(ATestCase, E, FFailures);
+      AddFailure(ATestCase, E, FFailures, ExceptAddr);
     on E: Exception do
       begin
-      {$ifdef SHOWLINEINFO}
-        GetLineInfo(LongWord(ExceptAddr), func, source, line);
-      {$endif}
-        AddError(ATestCase, E, source, func, line);
+        AddError(ATestCase, E, ExceptAddr);
       end;
   end;
 end;
@@ -1279,7 +1417,7 @@ begin
 //unlock mutex
 end;
 
-function TTestResult.SkipTest(ATestCase: TTestCase): Boolean;
+function TTestResult.SkipTest(ATestCase: TTestCase): boolean;
 var
   i: integer;
 begin
@@ -1292,7 +1430,7 @@ begin
   else
     for i := 0 to FSkippedTests.Count - 1 do
     begin
-      if PtrInt(FSkippedTests[i]) = PtrInt(ATestCase) then
+      if PtrUInt(FSkippedTests[i]) = PtrUInt(ATestCase) then
       begin
         Result := true;
         Exit;

packages/fcl-fpcunit/src/fpcunitreport.pp

@@ -68,6 +68,8 @@ type
   private
     FLevel: integer;
     FCount: integer;
+    FSkipAddressInfo: Boolean;
+    FSparse: Boolean;
     FTestTime: TDateTime;
     FFileName: string;
     FSuiteResultsStack : TSuiteResultsStack;
@@ -83,6 +85,8 @@ type
     FOnEndTestSuite: TTestEvent;
     FSkipTiming: Boolean;
   protected
+    procedure SetSkipAddressInfo(AValue: Boolean); virtual;
+    procedure SetSparse(AValue: Boolean); virtual;
     procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); virtual;
     procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); virtual;
     procedure WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); virtual;
@@ -122,7 +126,9 @@ type
     property OnStartTestSuite: TTestEvent read FOnStartTestSuite write FOnStartTestSuite;
     property OnEndTestSuite: TTestEvent read FOnEndTestSuite write FOnEndTestSuite;
     Property SkipTiming : Boolean Read FSkipTiming Write FSkipTiming;
-  end; 
+    Property Sparse : Boolean Read FSparse Write SetSparse;
+    Property SkipAddressInfo : Boolean Read FSkipAddressInfo Write SetSkipAddressInfo;
+  end;
 
 implementation
 
@@ -272,6 +278,18 @@ begin
     FOnAddError(Self, ATest, AError);
 end;
 
+procedure TCustomResultsWriter.SetSkipAddressInfo(AValue: Boolean);
+begin
+  if FSkipAddressInfo=AValue then Exit;
+  FSkipAddressInfo:=AValue;
+end;
+
+procedure TCustomResultsWriter.SetSparse(AValue: Boolean);
+begin
+  if FSparse=AValue then Exit;
+  FSparse:=AValue;
+end;
+
 procedure TCustomResultsWriter.WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer);
 begin
   if Assigned(FOnWriteTestHeader) then 
@@ -291,9 +309,9 @@ begin
     FOnWriteSuiteHeader(Self, ATestSuite, ALevel);
 end;
 
-procedure TCustomResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 
-  ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer;
-  ANumIgnores: integer);
+procedure TCustomResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite;
+  ALevel: integer; ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer;
+  aNumFailures: integer; ANumIgnores: integer);
 begin
   if Assigned(FOnWriteSuiteFooter) then 
     FOnWriteSuiteFooter(Self, ATestSuite, ALevel, ATiming, ANumRuns, ANumErrors, 

packages/fcl-fpcunit/src/plaintestreport.pp

@@ -22,16 +22,21 @@ uses
   classes, SysUtils, fpcunit, fpcunitreport;
 
 type
+  TTestResultOption = (ttoSkipAddress,ttoSkipExceptionMessage,ttoErrorsOnly);
+  TTestResultOptions = set of TTestResultOption;
 
   { TPlainResultsWriter }
 
   TPlainResultsWriter = class(TCustomResultsWriter)
   private
+    FTestResultOptions : TTestResultOptions;
     FDoc: TStringList;
     FSuiteHeaderIdx: TFPList;
     FTempFailure: TTestFailure;
     function TimeFormat(ATiming: TDateTime): String;
   protected
+    procedure SetSkipAddressInfo(AValue: Boolean); override;
+    procedure SetSparse(AValue: Boolean); override;
     procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); override;
     procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); override;
     procedure WriteSuiteHeader(ATestSuite: TTestSuite; ALevel: integer); override;
@@ -47,9 +52,10 @@ type
     procedure AddError(ATest: TTest; AError: TTestFailure); override;
   end;
 
-function TestSuiteAsPlain(aSuite:TTestSuite): string;
-function GetSuiteAsPlain(aSuite: TTestSuite): string;
-function TestResultAsPlain(aTestResult: TTestResult): string;
+
+function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;
+function GetSuiteAsPlain(aSuite: TTestSuite; Options : TTestResultOptions = []): string;
+function TestResultAsPlain(aTestResult: TTestResult; Options : TTestResultOptions = []): string;
 
 implementation
 
@@ -83,7 +89,7 @@ begin
   system.Assign(f, FileName);
   rewrite(f);
   FDoc.Add('');
-  FDoc.Add(TestResultAsPlain(aResult));
+  FDoc.Add(TestResultAsPlain(aResult,FTestResultOptions));
   writeln(f, FDoc.Text);
   close(f);
 end;
@@ -116,6 +122,7 @@ begin
   if Not SkipTiming then
     S:=S + FormatDateTime(TimeFormat(ATiming), ATiming) + '  ';
   S:=S + ATest.TestName;
+  if Assigned(FTempFailure) or (not Sparse) then
   FDoc.Add(S);
   if Assigned(FTempFailure) then
   begin
@@ -124,10 +131,8 @@ begin
     begin
       FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Error: ' + FTempFailure.ExceptionClassName;
       FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Source unit: ' + FTempFailure.SourceUnitName);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Method name: ' + FTempFailure.FailedMethodName);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Line number: ' 
-        + IntToStr(FTempFailure.LineNumber));
+      FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
+      // TODO: Add stack dump output info
     end
     else
       if FTempFailure.IsIgnoredTest then
@@ -136,14 +141,18 @@ begin
            + FTempFailure.ExceptionMessage;
       end
       else
+      begin
         //is a failure
         FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Failed: ' 
           + FTempFailure.ExceptionMessage;
+        FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
+        FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
+      end;
   end;
   FTempFailure := nil;
 end;
 
-Function TPlainResultsWriter.TimeFormat(ATiming : TDateTime) : String;
+function TPlainResultsWriter.TimeFormat(ATiming: TDateTime): String;
 
 Var
   M : Int64;
@@ -157,6 +166,24 @@ begin
    Result:='mm:'+Result;
 end;
 
+procedure TPlainResultsWriter.SetSkipAddressInfo(AValue: Boolean);
+begin
+  inherited SetSkipAddressInfo(AValue);
+  if AValue then
+    Include(FTestResultOptions,ttoSkipAddress)
+  else
+    Exclude(FTestResultOptions,ttoSkipAddress);
+end;
+
+procedure TPlainResultsWriter.SetSparse(AValue: Boolean);
+begin
+  inherited SetSparse(AValue);
+  if AValue then
+    FTestResultOptions:=FTestResultOptions+[ttoSkipExceptionMessage,ttoErrorsOnly]
+  else
+    FTestResultOptions:=FTestResultOptions-[ttoSkipExceptionMessage,ttoErrorsOnly];
+end;
+
 procedure TPlainResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 
   ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer;
   ANumIgnores: integer);
@@ -181,28 +208,39 @@ begin
   FSuiteHeaderIdx.Add(Pointer(FDoc.Count - 1));
 end;
 
-function TestSuiteAsPlain(aSuite:TTestSuite): string;
+function TestSuiteAsPlain(aSuite:TTestSuite; Options : TTestResultOptions = []): string;
 var
   i: integer;
 begin
   Result := '';
   for i := 0 to aSuite.Tests.Count - 1 do
     if TTest(aSuite.Tests.Items[i]) is TTestSuite then
-      Result := Result + TestSuiteAsPlain(TTestSuite(aSuite.Tests.Items[i]))
+      Result := Result + TestSuiteAsPlain(TTestSuite(aSuite.Tests.Items[i]),Options)
     else
       if TTest(aSuite.Tests.Items[i]) is TTestCase then
         Result := Result + '  ' + ASuite.TestName+'.' + TTestcase(aSuite.Tests.Items[i]).TestName + System.sLineBreak;
 end;
 
-function GetSuiteAsPlain(aSuite: TTestSuite): string;
+function GetSuiteAsPlain(aSuite: TTestSuite; Options : TTestResultOptions = []): string;
 begin
   Result := '';
-
   if aSuite <> nil then
-    Result := 'TestSuites: ' + System.sLineBreak + TestSuiteAsPlain(aSuite);
+    Result := 'TestSuites: ' + System.sLineBreak + TestSuiteAsPlain(aSuite,Options);
 end;
 
-function TestResultAsPlain(aTestResult: TTestResult): string;
+function TestResultAsPlain(aTestResult: TTestResult; Options : TTestResultOptions = []): string;
+
+  Procedure WriteFailure(F : TTestFailure; SkipAddress : Boolean = False );
+
+  begin
+    Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
+    Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
+    if not (ttoSkipExceptionMessage in options) then
+      Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+    if not (SkipAddress or (ttoSkipAddress in options) )then
+      Result := Result + '        at ' + f.LocationInfo + System.sLineBreak;
+  end;
+
 var
   i: longint;
   f: TTestFailure;
@@ -221,13 +259,7 @@ begin
       begin
         Result := Result + System.sLineBreak;
         Result := Result + '  Error: ' + System.sLineBreak;
-        f := TTestFailure(Errors.Items[i]);
-        Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
-        Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
-        Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
-        Result := Result + '    Source unitname:   ' + f.SourceUnitName + System.sLineBreak;
-        Result := Result + '    Line number:       ' + IntToStr(f.LineNumber) + System.sLineBreak;
-        Result := Result + '    Failed methodname: ' + f.FailedMethodName + System.sLineBreak;
+        WriteFailure(TTestFailure(Errors.Items[i]));
       end;
     end;
     if NumberOfFailures <> 0 then
@@ -238,10 +270,7 @@ begin
       for i := 0 to Failures.Count - 1 do
       begin
         Result := Result + '  Failure: ' + System.sLineBreak;
-        f := TTestFailure(Failures.Items[i]);
-        Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
-        Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
-        Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+        WriteFailure(TTestFailure(Failures.Items[i]));
       end;
     end;
    if NumberOfIgnoredTests <> 0 then
@@ -252,10 +281,7 @@ begin
       for i := 0 to IgnoredTests.Count - 1 do
       begin
         Result := Result + '  Ignored test: ' + System.sLineBreak;
-        f := TTestFailure(IgnoredTests.Items[i]);
-        Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
-        Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
-        Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+        WriteFailure(TTestFailure(IgnoredTests.Items[i]),True);
       end;
     end;
   end;

packages/fcl-fpcunit/src/tests/asserttest.pp

@@ -23,6 +23,8 @@ uses
 
 type
 
+  { TAssertTest }
+
   TAssertTest = class(TTestCase)
   published
     procedure TestFail;
@@ -37,11 +39,25 @@ type
     procedure TestAssertTrue;
     procedure TestAssertFalse;
     procedure TestAssertNotSame;
+    procedure TestExpectExceptionOK;
+    procedure TestExpectExceptionNoException;
+    procedure TestExpectExceptionWrongExceptionClass;
+    procedure TestExpectExceptionWrongExceptionMessage;
+    procedure TestExpectExceptionWrongExceptionContext;
   end;
 
+  EMyException = Class(Exception);
+
+  { TMyTest }
+
   TMyTest = class(TTestCase)
   published
     procedure RaiseIgnoreTest;
+    procedure TestExpectException;
+    procedure TestExpectExceptionNone;
+    procedure TestExpectExceptionWrongClass;
+    procedure TestExpectExceptionWrongMessage;
+    procedure TestExpectExceptionWrongHelpContext;
   end;
 
   TTestIgnore = class(TTestCase)
@@ -233,10 +249,115 @@ begin
   Fail('Error: Objects are the same!');
 end;
 
+procedure TAssertTest.TestExpectExceptionOK;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectException');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 0, res.NumberOfFailures);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionNoException;
+
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionNone');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception EMyException expected but no exception was raised',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionClass;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongClass');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception EMyException expected but Exception was raised',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionMessage;
+
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongMessage');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception raised but exception property Message differs:  expected: <A message> but was: <A wrong message>',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionContext;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongHelpContext');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception raised but exception property HelpContext differs:  expected: <123> but was: <124>',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
 procedure TMyTest.RaiseIgnoreTest;
 begin
   Ignore('This is an ignored test');
-  AssertEquals('the compiler can count', 3, 1+1); 
+  AssertEquals('the compiler can count', 3, 2);
+end;
+
+procedure TMyTest.TestExpectException;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionNone;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongClass;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise Exception.CreateHelp('A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongMessage;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A wrong message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongHelpContext;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A message',124);
 end;
 
 procedure TTestIgnore.TestIgnoreResult;
@@ -262,14 +383,14 @@ var
 begin
   t := TMyTest.CreateWithName('RaiseIgnoreTest');
   t.EnableIgnores := false;
-  res := t.CreateResultandRun;
+  res := t.CreateResultAndRun;
   assertEquals('no test was run', 1, res.RunTests);
   assertEquals('Ignored Test reported even if the switch is not active', 0, res.NumberOfIgnoredTests);
   assertEquals('no failure caught', 1, res.NumberOfFailures);
   assertFalse('failure is signalled as Ignored Test and the switch is not active', 
     TTestFailure(res.Failures[0]).IsIgnoredTest);
   assertEquals('wrong failure name', 'EAssertionFailedError', TTestFailure(res.Failures[0]).ExceptionClassName);
-  assertEquals('wrong message', 'the compiler can count expected: <3> but was: <2>', TTestFailure(res.Failures[0]).ExceptionMessage);
+  assertEquals('wrong message', '"the compiler can count" expected: <3> but was: <2>', TTestFailure(res.Failures[0]).ExceptionMessage);
   t.Free;
   res.Free;
 end;

packages/fcl-fpcunit/src/tests/frameworktest.pp

@@ -17,122 +17,22 @@
 program frameworktest;
 
 uses
-  custapp, classes, SysUtils, fpcunit, testreport, asserttest, suitetest;
+  consoletestrunner, classes, SysUtils, fpcunit, testreport, asserttest,
+  suitetest;
 
-Const
-  ShortOpts = 'alh';
-  Longopts : Array[1..5] of String = (
-    'all','list','format:','suite:','help');
-  Version = 'Version 0.1';
 
 Type
-  TTestRunner = Class(TCustomApplication)
-  private
-    FSuite: TTestSuite;
-    FXMLResultsWriter: TXMLResultsWriter;
-  protected
-    procedure DoRun ; Override;
-    procedure doTestRun(aTest: TTest); virtual;
-  public
-    constructor Create(AOwner: TComponent); override;
-    destructor Destroy; override;
-  end;
-
-
-constructor TTestRunner.Create(AOwner: TComponent);
-begin
-  inherited Create(AOwner);
-  FXMLResultsWriter := TXMLResultsWriter.Create;
-  FSuite := TTestSuite.Create;
-  FSuite.TestName := 'Framework test';
-  FSuite.AddTestSuiteFromClass(TAssertTest);
-  FSuite.AddTestSuiteFromClass(TTestIgnore);
-  FSuite.AddTest(TSuiteTest.Suite());
-end;
-
-destructor TTestRunner.Destroy;
-begin
-  FXMLResultsWriter.Free;
-  FSuite.Free;
-end;
-
-procedure TTestRunner.doTestRun(aTest: TTest);
-var
-  testResult: TTestResult;
-begin
-  testResult := TTestResult.Create;
-  try
-    testResult.AddListener(FXMLResultsWriter);
-    FXMLResultsWriter.WriteHeader;
-    aTest.Run(testResult);
-    FXMLResultsWriter.WriteResult(testResult);
-  finally
-    testResult.Free;
-  end;
-end;
-
-procedure TTestRunner.DoRun;
-var
-  I : Integer;
-  S : String;
-begin
-  S:=CheckOptions(ShortOpts,LongOpts);
-  If (S<>'') then
-    Writeln(S);
-  if HasOption('h', 'help') or (ParamCount = 0) then
-  begin
-    writeln(Title);
-    writeln(Version);
-    writeln('Usage: ');
-    writeln('-l or --list to show a list of registered tests');
-    writeln('default format is xml, add --format=latex to output the list as latex source');
-    writeln('-a or --all to run all the tests and show the results in xml format');
-    writeln('The results can be redirected to an xml file,');
-    writeln('for example: ./testrunner --all > results.xml');
-    writeln('use --suite=MyTestSuiteName to run only the tests in a single test suite class');
-  end
-  else;
-    if HasOption('l', 'list') then
-    begin
-      if HasOption('format') then
-      begin
-        if GetOptionValue('format') = 'latex' then
-          writeln(GetSuiteAsLatex(FSuite))
-        else
-          writeln(GetSuiteAsXML(FSuite));
-      end
-      else
-        writeln(GetSuiteAsXML(FSuite));
-    end;
-  if HasOption('a', 'all') then
-  begin
-    doTestRun(FSuite)
-  end
-  else
-    if HasOption('suite') then
-    begin
-      S := '';
-      S:=GetOptionValue('suite');
-      if S = '' then
-        for I := 0 to FSuite.Tests.count - 1 do
-          writeln(FSuite[i].TestName)
-      else
-      for I := 0 to FSuite.Tests.count - 1 do
-        if FSuite[i].TestName = S then
-        begin
-          doTestRun(FSuite.Test[i]);
-        end;
-    end;
-  Terminate;
-end;
+  TFPCUnitRunner = Class(TTestRunner);
 
 Var
-  App : TTestRunner;
+  App : TFPCUnitRunner;
 
 begin
-  App:=TTestRunner.Create(Nil);
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
+  App:=TFPCUnitRunner.Create(Nil);
   App.Initialize;
-  App.Title := 'FPCUnit Console Test Case runner.';
+  App.Title := 'FPCUnit Test Suite';
   App.Run;
   App.Free;
 end.

packages/fcl-image/src/fpreadpng.pp

@@ -403,20 +403,24 @@ end;
 function TFPReaderPNG.CalcColor: TColorData;
 var cd : longword;
     r : word;
-    b : byte;
-    tmp : pbytearray;
+    b : pbyte;
 begin
   if UsingBitGroup = 0 then
     begin
     Databytes := 0;
     if Header.BitDepth = 16 then
       begin
-       getmem(tmp, bytewidth);
-       fillchar(tmp^, bytewidth, 0);
-       for r:=0 to bytewidth-2 do
-        tmp^[r+1]:=FCurrentLine^[Dataindex+r];
-       move (tmp^[0], Databytes, bytewidth);
-       freemem(tmp);
+        b := @Databytes;
+        b^ := 0;
+        r := 0;
+        while (r < ByteWidth-1) do
+        begin
+          b^ := FCurrentLine^[DataIndex+r+1];
+          inc (b);
+          b^ := FCurrentLine^[DataIndex+r];
+          inc (b);
+          inc (r,2);
+        end;
       end
     else move (FCurrentLine^[DataIndex], Databytes, bytewidth);
     {$IFDEF ENDIAN_BIG}

packages/fcl-image/src/fpreadtiff.pas

@@ -213,8 +213,8 @@ begin
   for i:=0 to SampleCnt-1 do begin
     if SampleBits[i]>64 then
       TiffError('Samples bigger than 64 bit not supported');
-    if not (SampleBits[i] in [1, 8, 16]) then
-      TiffError('Only samples of 1, 8 and 16 bit are supported');
+    if not (SampleBits[i] in [1, 8, 12, 16]) then
+      TiffError('Only samples of 1, 8, 12 and 16 bit are supported');
     inc(SampleBitsPerPixel, SampleBits[i]);
   end;
   case IFD.PhotoMetricInterpretation of
@@ -228,8 +228,8 @@ begin
           IFD.AlphaBits:=AlphaBits;
         end;
       end;
-      if not (GrayBits in [1, 8, 16]) then
-        TiffError('gray image only supported with gray BitsPerSample 1, 8 or 16');
+      if not (GrayBits in [1, 8, 12, 16]) then
+        TiffError('gray image only supported with gray BitsPerSample 1, 8, 12 or 16');
       if not (AlphaBits in [0, 8, 16]) then
         TiffError('gray image only supported with alpha BitsPerSample 8 or 16');
     end;
@@ -366,6 +366,7 @@ procedure TFPReaderTiff.ReadImgValue(BitCount: Word; var Run: Pointer; x: dword;
   Predictor: word; var LastValue: word; out Value: Word); inline;
 var
   BitNumber: byte;
+  Byte1, Byte2: byte;
 begin
   case BitCount of
   1:
@@ -391,6 +392,18 @@ begin
       Value:=Value shl 8+Value;
       inc(Run);
     end;
+  12:
+    begin
+      Byte1 := PCUInt8(Run)^;
+      Byte2 := PCUInt8(Run+1)^;
+      if (x mod 2) = 0 then begin
+        Value := (((Byte1) shl 4) or (Byte2 shr 4)) * 16;
+        inc(Run);
+      end else begin
+        Value := (((Byte1 and $0F) shl 8) or Byte2) * 16;
+        inc(Run, 2);
+      end;
+    end;
   16:
     begin
       Value:=FixEndian(PCUInt16(Run)^);
@@ -551,6 +564,9 @@ begin
   if Debug then
     writeln('ReadIFD Start=',Start);
   {$endif}
+  // set default values if not read from file
+  IFD.RowsPerStrip := $FFFFFFFF;
+  
   Result:=0;
   SetStreamPos(Start);
   IFD.IFDStart:=Start;
@@ -1973,7 +1989,7 @@ begin
   for i:=0 to ImageCount-1 do begin
     CurImg:=Images[i];
     NewSize:=Int64(CurImg.ImageWidth)*CurImg.ImageHeight;
-    if (NewSize<BestSize) then continue;
+    if (NewSize<=BestSize) then continue;
     BestSize:=NewSize;
     Best:=i;
   end;

packages/fcl-image/src/fpwritepng.pp

@@ -34,6 +34,7 @@ type
       CFmt : TColorFormat; // format of the colors to convert from
       FFmtColor : TColorFormatFunction;
       FTransparentColor : TFPColor;
+      FTransparentColorOk: boolean;
       FSwitchLine, FCurrentLine, FPreviousLine : pByteArray;
       FPalette : TFPPalette;
       OwnsPalette : boolean;
@@ -83,6 +84,7 @@ type
       property ChunkDataBuffer : pByteArray read FChunk.data;
       property UsetRNS : boolean read FUsetRNS;
       property SingleTransparentColor : TFPColor read FTransparentColor;
+      property SingleTransparentColorOk : boolean read FTransparentColorOk;
       property ThePalette : TFPPalette read FPalette;
       property ColorFormat : TColorformat read CFmt;
       property ColorFormatFunc : TColorFormatFunction read FFmtColor;
@@ -270,18 +272,38 @@ end;
 
 procedure TFPWriterPNG.DetermineHeader (var AHeader : THeaderChunk);
 var c : integer;
+
+  function ReducedColorEquals(const c1,c2: TFPColor): boolean;
+  var g1,g2: word;
+  begin
+    if FGrayScale then
+      begin
+        g1 := CalculateGray(c1);
+        g2 := CalculateGray(c2);
+        if fwordsized then
+          result := (g1 = g2)
+        else
+          result := (g1 shr 8 = g2 shr 8);
+      end else
+      begin
+        if FWordSized then
+          result := (c1.red = c2.red) and (c1.green = c2.green) and (c1.blue = c2.blue)
+        else
+          result := (c1.red shr 8 = c2.red shr 8) and (c1.green shr 8 = c2.green shr 8) and (c1.blue shr 8 = c2.blue shr 8);
+      end;
+  end;
+
   function CountAlphas : integer;
   var none, half : boolean;
-      x,y : longint;  // warning, checks on <0 !
+      maxTransparentAlpha: word;
+
+    procedure CountFromPalettedImage;
+    var
       p : integer;
-      c : TFPColor;
       a : word;
+      c : TFPColor;
   begin
-    half := false;
-    none := false;
-    with TheImage do
-      if UsePalette then
-        with Palette do
+      with TheImage.Palette do
           begin
           p := count-1;
           FTransparentColor.alpha := alphaOpaque;
@@ -289,39 +311,95 @@ var c : integer;
             begin
             c := color[p];
             a := c.Alpha;
-            if a = alphaTransparent then
+          if a <= maxTransparentAlpha then
               begin
               none := true;
+            if a < FTransparentColor.alpha then
               FTransparentColor := c;
               end
-            else if a <> alphaOpaque then
-              begin
-              half := true;
-              if FtransparentColor.alpha < a then
-                FtransparentColor := c;
-              end;
+          else if a <> alphaOpaque then half := true;
             dec (p);
             end;
+
+        //check transparent color is used consistently
+        FTransparentColorOk := true;
+        p := count-1;
+        while (p >= 0) do
+          begin
+          c := color[p];
+          if c.alpha > maxTransparentAlpha then
+          begin
+            if ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
           end
       else
+        begin
+            if not ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
+          end;
+          dec(p);
+          end;
+        end;
+    end;
+
+    procedure CountFromRGBImage;
+    var
+      a : word;
+      c : TFPColor;
+      x,y : longint;  // checks on < 0
+    begin
+      with TheImage do
         begin
         x := width-1;
         y := height-1;
         FTransparentColor.alpha := alphaOpaque;
-        while (y >= 0) and not (half and none) do
+        while (y >= 0) and not half do //we stop if we already need a full alpha
           begin
           c := colors[x,y];
           a := c.Alpha;
-          if a = alphaTransparent then
+          if a <= maxTransparentAlpha then
             begin
             none := true;
+            if a < FTransparentColor.alpha then
             FTransparentColor := c;
             end
-          else if a <> alphaOpaque then
+          else if a <> alphaOpaque then half := true;
+          dec (x);
+          if (x < 0) then
             begin
-            half := true;
-            if FtransparentColor.alpha < a then
-              FtransparentColor := c;
+            dec (y);
+            x := width-1;
+            end;
+          end;
+
+        //check transparent color is used consistently
+        FTransparentColorOk := true;
+        x := width-1;
+        y := height-1;
+        while (y >= 0) do
+          begin
+          c := colors[x,y];
+          if c.alpha > maxTransparentAlpha then
+          begin
+            if ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
+          end
+          else
+          begin
+            if not ReducedColorEquals(c, FTransparentColor) then
+              begin
+              FTransparentColorOk := false;
+              break;
+              end;
             end;
           dec (x);
           if (x < 0) then
@@ -331,11 +409,34 @@ var c : integer;
             end;
           end;
         end;
-      result := 1;
+    end;
+
+  begin
+    FTransparentColorOk := false;
+    if FWordSized then maxTransparentAlpha := 0
+    else maxTransparentAlpha := $00ff;
+    half := false;
+    none := false;
+    with TheImage do
+      if UsePalette then
+        CountFromPalettedImage
+      else
+        CountFromRGBImage;
+
+    if half then //if there are semitransparent colors,
+                 //an alpha channel is needed
+      result := 3
+    else
       if none then
-        inc (result);
-      if half then
-        inc (result);
+      begin
+      if FTransparentColorOk then
+        result := 2 //it is possible to use tRNS only
+                    //if the transparent color is used consistently
+      else
+        result := 3;
+      end
+    else
+      result := 1;
   end;
   procedure DetermineColorFormat;
   begin
@@ -660,7 +761,7 @@ procedure TFPWriterPNG.WritetRNS;
   procedure PaletteAlpha;
   var r : integer;
   begin
-    with TheImage.palette do
+    with FPalette do
       begin
       // search last palette entry with transparency
       r := count;