Chip 2004 March/Chip_2004-03_cd1.bin/program/delphi/download/kompon/d234567/DIIconv.exe/Source/DIIconv.pas

Pascal/Delphi Source File | 2004-01-02 | 6.8 KB | 321 lines

{-------------------------------------------------------------------------------

 DIIconv - libiconv character set conversion library for Borland Delphi.

 Copyright (c) 2003-2004 The Delphi Inspiration - Ralf Junker
 Internet: http://www.zeitungsjunge.de/delphi/
 E-Mail:   [e-mail]

 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 library 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 DIIconv;

{$I DI.inc}

interface

const

  EINVAL = 19;

  E2BIG = 20;

  EILSEQ = 50;

  ICONV_TRIVIALP = 0;

  ICONV_GET_TRANSLITERATE = 1;

  ICONV_SET_TRANSLITERATE = 2;

  ICONV_GET_DISCARD_ILSEQ = 3;

  ICONV_SET_DISCARD_ILSEQ = 4;

type

  iconv_t = Pointer;

function iconv_open(
  const tocode, fromcode: PAnsiChar): iconv_t;

function iconv(
  const CD: iconv_t;
  var inbuf: Pointer;
  var inbytesleft: Cardinal;
  var outbuf: Pointer;
  var outbytesleft: Cardinal): Integer;

function iconv_close(
  const CD: iconv_t): Integer;

type
  TAnsiCharArray = array[0..MaxInt div SizeOf(PAnsiChar) - 1] of PAnsiChar;
  PAnsiCharArray = ^TAnsiCharArray;

  TIconvListFunc = function(const NamesCount: Cardinal; const Names: PAnsiCharArray; const Data: Pointer): Integer;

procedure iconvlist(do_one: TIconvListFunc; const Data: Pointer);

function errno: Integer;

implementation

uses
  Windows, SysUtils

  ;

function _malloc(const Size: Cardinal): Pointer; cdecl;
begin
  GetMem(Result, Size);
end;

procedure _free(const p: Pointer); cdecl;
begin
  FreeMem(p);
end;

function _memcmp(const s1: Pointer; const s2: Pointer; const n: Cardinal): Integer; cdecl;
label
  Success;
type
  TByte4 = packed record
    b0, b1, b2, b3: Byte;
  end;
  PByte4 = ^TByte4;
var
  p1, p2: PByte4;
  b1, b2: Byte;
  l: Cardinal;
begin
  p1 := s1;
  p2 := s2;
  if p1 = p2 then goto Success;
  l := n;

  repeat
    if l = 0 then goto Success;
    b1 := p1^.b0; b2 := p2^.b0;
    if b1 <> b2 then Break;
    Dec(l);

    if l = 0 then goto Success;
    b1 := p1^.b1; b2 := p2^.b1;
    if b1 <> b2 then Break;
    Dec(l);

    if l = 0 then goto Success;
    b1 := p1^.b2; b2 := p2^.b2;
    if b1 <> b2 then Break;
    Dec(l);

    if l = 0 then goto Success;
    b1 := p1^.b3; b2 := p2^.b3;
    if b1 <> b2 then Break;

    Inc(p1);
    Inc(p2);
    Dec(l);
  until False;

  Result := b1 - b2;
  Exit;

  Success:
  Result := 0;
end;

function _memset(const s: Pointer; const c: Integer; const n: Cardinal): Pointer; cdecl;
begin
  Result := s;
  FillChar(Result^, n, c);
end;

type
  TQSortCompareFunc = function(const p1, p2: Pointer): Integer; cdecl;

procedure _qsort(
  const baseP: Pointer;
  const NElem: Cardinal;
  const Width: Integer;
  const comparF: TQSortCompareFunc); cdecl;

  procedure Exchange(leftP, rightP: PAnsiChar);
  var
    i: Integer;
    c: AnsiChar;
  begin
    i := Width;
    while i > 0 do
      begin
        c := rightP^;
        rightP^ := leftP^;
        Inc(rightP);
        leftP^ := c;
        Inc(leftP);
        Dec(i);
      end;
  end;

  procedure qSortHelp(pivotP: PAnsiChar; NElem: Integer);
  label
    TailRecursion, qBreak;
  var
    leftP, rightP, pivotEnd, pivotTemp, leftTemp: PAnsiChar;
    lNum: Integer;
    retval: Integer;
  begin

    TailRecursion:
    if NElem <= 2 then
      begin
        if NElem = 2 then
          begin
            rightP := pivotP + Width;
            if comparF(pivotP, rightP) > 0 then
              Exchange(pivotP, rightP);
          end;
        Exit;
      end;

    rightP := (NElem - 1) * Width + pivotP;
    leftP := (NElem shr 1) * Width + pivotP;

    if comparF(leftP, rightP) > 0 then
      Exchange(leftP, rightP)
    else
      if comparF(leftP, pivotP) > 0 then
        Exchange(leftP, pivotP)
      else
        if comparF(pivotP, rightP) > 0 then
          Exchange(pivotP, rightP);

    if (NElem = 3) then
      begin
        Exchange(pivotP, leftP);
        Exit;
      end;

    leftP := pivotP + Width;
    pivotEnd := leftP;

    repeat
      retval := comparF(leftP, pivotP);
      while retval <= 0 do
        begin
          if retval = 0 then
            begin
              Exchange(leftP, pivotEnd);
              Inc(pivotEnd, Width);
            end;
          if (leftP < rightP) then
            Inc(leftP, Width)
          else
            goto qBreak;
          retval := comparF(leftP, pivotP);
        end;

      while leftP < rightP do
        begin
          retval := comparF(pivotP, rightP);
          if retval < 0 then
            Dec(rightP, Width)
          else
            begin
              Exchange(leftP, rightP);
              if retval <> 0 then
                begin
                  Inc(leftP, Width);
                  Dec(rightP, Width);
                end;
              Break;
            end;
        end;

    until not (leftP < rightP);

    qBreak:

    if comparF(leftP, pivotP) <= 0 then
      Inc(leftP, Width);

    leftTemp := leftP - Width;

    pivotTemp := pivotP;

    while (pivotTemp < pivotEnd) and (leftTemp >= pivotEnd) do
      begin
        Exchange(pivotTemp, leftTemp);
        Inc(pivotTemp, Width);
        Dec(leftTemp, Width);
      end;

    lNum := (leftP - pivotEnd) div Width;
    NElem := ((NElem * Width + pivotP) - leftP) div Width;

    if NElem < lNum then
      begin
        qSortHelp(leftP, NElem);
        NElem := lNum;
      end
    else
      begin
        qSortHelp(pivotP, lNum);
        pivotP := leftP;
      end;

    goto TailRecursion;
  end;

begin
  if Width = 0 then Exit;
  qSortHelp(baseP, NElem);
end;

var
  LocaleCharset: array[0..12] of AnsiChar = 'CP';

function locale_charset: PAnsiChar; cdecl;
var
  s: ShortString;
begin
  Str(GetACP, s);
  StrLCopy(@LocaleCharset[2], @s[1], SizeOf(LocaleCharset) - 2);
  LocaleCharset[Length(s) + 2] := #0;
  Result := LocaleCharset;
end;

var
  _errno: Integer;

function errno: Integer;
begin
  Result := _errno;
end;

{$L iconv.obj}

function iconv_open; external;
function iconv; external;
function iconv_close; external;
procedure iconvlist; external;

end.