unit supplieds;

{$IFDEF FPC}
  {$MODE DELPHI}{$H+}
{$ENDIF}

(***************************************)
(* Copyright (C) 2003, SHIRAISHI Kazuo *)
(***************************************)


interface
uses  sysUtils, {LCLProc,}
   variabl;

implementation
uses  LazUTF8,
      myutils,base,base0,texthand,struct,express,helpctex,supplied;



{*************}
{str$ function}
{*************}

type
   Tstr=class(TStrExpression)
             exp:TPrincipal;
             CharacterByte:boolean;
          constructor create;

          destructor destroy;override;
          function Code:AnsiString;override;
     end;

constructor Tstr.create;
begin
   inherited create;
   exp:=argumentN1;
   {if exp=nil then fail;}
   CharacterByte:=ProgramUnit.CharacterByte;
end;
(*
function Tstr.evalS:ansistring;
begin
  result:=trim(exp.str);
end;
*)
destructor Tstr.destroy;
begin
   exp.free;
   inherited destroy;
end;

function TSTR.Code:ansistring;
begin
   result:='STR_s('+exp.Code+')'
end;

function strfnc:TPrincipal;
begin
   strfnc:=Tstr.create;
end;

{*************}
{CHR$ function}
{*************}
type
  TCHRfnc=Class(Tstr)

       function Code:AnsiString;override;
  end;



function TCHRfnc.Code:ansistring;
begin
  if characterbyte then
    result:='CHRbyte('+exp.Code+')'
  else
    result:='CHR_s('+exp.Code+')'
end;






function CHRfnc:TPrincipal;
begin
  CHRfnc:=TCHRfnc.create
end;

{***************}
{USING$ function}
{***************}

type
   TstrfunctionSN=class(TstrExpression)
      exp1,exp2:TPrincipal;
      CharacterByte:boolean;
      constructor  create;
      destructor    destroy;override;
   end;

   TRepeat=class(TstrfunctionSN)

      function Code:AnsiString;override;
   end;

   TUsing=class(TstrfunctionSN)
      insideofwhen:boolean;
      constructor  create;

      function Code:AnsiString;override;
   end;

constructor TstrfunctionSN.create;
begin
   inherited create;
   CharacterByte:=ProgramUnit.CharacterByte;
   check('(',IDH_STRING_FUNCTIONS);
   exp1:=SExpression;
   check(',',IDH_STRING_FUNCTIONS);
   exp2:=NExpression;
   check(')',IDH_STRING_FUNCTIONS);
end;

destructor TstrfunctionSN.destroy;
begin
    exp1.free;
    exp2.free;
   inherited destroy;
end;

constructor TUsing.create;
begin
  inherited create;
  with whenStack do insideofwhen:=items[count-1]<>nil;
end;


function TUsing.Code:Ansistring;
begin
   if insideofwhen then
     Result:='USING_ss('+exp1.code+','+exp2.Code+')'
   else
     Result:='USING_s('+exp1.code+','+exp2.Code+')'
end;

function Usingfnc:TPrincipal;
begin
  Usingfnc:=TUsing.create
end;


function TRepeat.Code:Ansistring;
begin
   Result:='REPEAT_s('+exp1.code+','+exp2.Code+')'
end;

function Repeatfnc:TPrincipal;
begin
   Repeatfnc:=TRepeat.create
end;

{***********************}
{ Left$, Right$ function}
{***********************}
type
   TLeft=class(TstrfunctionSN)

       function Code:AnsiString;override;
   end;

   TRight=class(TstrfunctionSN)

       function Code:AnsiString;override;
   end;


function Leftfnc:TPrincipal;
begin
   Leftfnc:=TLeft.create
end;
function Rightfnc:TPrincipal;
begin
   Rightfnc:=TRight.create
end;



{**********************}
{ SUBSTR$ function,etc.}
{**********************}
type
   TstrfunctionSNN=class(TstrExpression)
      exp1,exp2,exp3:TPrincipal;
      CharacterByte:boolean;
      constructor  create;
      destructor   destroy;override;
   end;

   TSubStr=class(TstrfunctionSNN)

       function Code:AnsiString;override;
   end;

   TMid=class(TstrfunctionSNN)

       function Code:AnsiString;override;
   end;

constructor TstrfunctionSNN.create;
begin
   inherited create;
   CharacterByte:=ProgramUnit.CharacterByte;
   check('(',IDH_STRING_FUNCTIONS);
   exp1:=SExpression;
   check(',',IDH_STRING_FUNCTIONS);
   exp2:=NExpression;
   check(',',IDH_STRING_FUNCTIONS);
   exp3:=NExpression;
   check(')',IDH_STRING_FUNCTIONS);
end;

destructor TstrfunctionSNN.destroy;
begin
    exp1.free;
    exp2.free;
    exp3.free;
   inherited destroy;
end;

function SubStrfnc:TPrincipal;
begin
  SubStrfnc:=TSubStr.create
end;

function Midfnc:TPrincipal;
begin
  Midfnc:=TMid.create
end;

function TSubStr.Code:Ansistring;
begin
  if CharacterByte then
     result:='SubstringByte('+exp1.code+','+exp2.code+','+exp3.code+')'
  else
     result:='Substring('+exp1.code+','+exp2.code+','+exp3.code+')'
end;

function TMid.Code:Ansistring;
begin
  if CharacterByte then
     result:='Mid_sByte('+exp1.code+','+exp2.code+','+exp3.code+')'
  else
     result:='Mid_s('+exp1.code+','+exp2.code+','+exp3.code+')'
end;

function TLeft.Code:Ansistring;
begin
  if CharacterByte then
     result:='Left_sByte('+exp1.code+','+exp2.code+')'
  else
     result:='Left_s('+exp1.code+','+exp2.code+')'
end;

function TRight.Code:Ansistring;
begin
  if CharacterByte then
     result:='Right_sByte('+exp1.code+','+exp2.code+')'
  else
     result:='Right_s('+exp1.code+','+exp2.code+')'
end;



{********************}
{ DATE,TIME functions}
{********************}

function format2(i:integer):ansistring;
var
   s:ansistring;
begin
   system.str(i:2,s);
   if s[1]=' ' then s[1]:='0';
   format2:=s
end;


type
    TDATE=class(TStrExpression)

       function Code:AnsiString;override;
    end;

function  DATEfnc:TPrincipal;
begin
    DATEfnc:=TDATE.create
end;


type
    TTIME=class(TStrExpression)

       function Code:AnsiString;override;
    end;

function  TIMEfnc:TPrincipal;
begin
    TIMEfnc:=TTIME.create
end;

function TTime.Code:AnsiString;
begin
  result:='TIME_s'
end;

function TDate.Code:AnsiString;
begin
  result:='DATE_s'
end;



{**************}
{LCASE function}
{**************}

procedure MyTrimLeft(var s:string);
var
  i:integer;
begin
  i:=0;
  while (i<length(s)) and (s[i+1]=' ') do inc(i);
  delete(s,1,i);
end;

procedure MyTrimRight(var s:string);
var
  i:integer;
begin
  i:=Length(s);
  while (i>0) and (s[i]=' ') do dec(i);
  delete(s,i+1,length(s)-i);
end;


type
   StringProcedure=procedure(var s:string);

   TLCASE=class(TStrExpression)
             exp:TPrincipal;
             f:StringProcedure;
          constructor create(f1:stringprocedure);

          destructor destroy;override;
          function Code:AnsiString;override;
     end;

constructor TLCASE.create(f1:StringProcedure);
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp:=SExpression;
    check(')',IDH_STRING_FUNCTIONS);
    f:=f1;
end;

function TLCASE.Code:AnsiString;
begin
  if @f = @Upper then
     result:='UpperCase('+exp.code+')'
  else if @f = @Lower then
     result:='LowerCase('+exp.code+')'
  else if @f = @MyTrimRight then
     result:='RTRIM_s('+exp.code+')'
  else if @f = @MyTrimLeft then
     result:='LTRIM_s('+exp.code+')'

end;

destructor TLCASE.destroy;
begin
   exp.free;
   inherited destroy;
end;

function LCASEfnc:TPrincipal;
begin
   LCASEfnc:=TLCASE.create(Lower);
end;


function UCASEfnc:TPrincipal;
begin
   UCASEfnc:=TLCASE.create(Upper);
end;

function LTRIMfnc:TPrincipal;
begin
   LTRIMfnc:=TLCASE.create(MyTrimLeft);
end;

function RTRIMfnc:TPrincipal;
begin
   RTRIMfnc:=TLCASE.create(MyTrimRight);
end;

{******}
{BSTR$ }
{******}
type
   TBSTR=class(TStrExpression)
             exp:TPrincipal;
             bin:boolean;
          constructor create;

          destructor destroy;override;
          function Code:AnsiString;override;
      end;

constructor TBSTR.create;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp:=NExpression;
    check(',',IDH_STRING_FUNCTIONS);
    if token='2' then
       begin gettoken; bin:=true end
    else
       checktoken1('16',IDH_STRING_FUNCTIONS);
    check(')',IDH_STRING_FUNCTIONS);
end;

destructor TBSTR.destroy;
begin
   exp.free;
   inherited destroy;
end;

function TBStr.Code:AnsiString;
begin
 if bin then
    result:='BSTR_s('+exp.Code+',2)'
 else
    result:='BSTR_s('+exp.Code+',16)'
end;

function BSTRfnc:TPrincipal;
begin
   BSTRfnc:=TBSTR.create;
end;


{*******}
{EXTEXT$}
{*******}
type
     TEXTEXT=class(TStr)

       function Code:ansistring;override;
     end;

function TEXTEXT.Code:ansistring;
begin
  result:='ExMess(E,ExcodeRec)';
end;

function EXTEXTfnc:TPrincipal;
begin
   EXTEXTfnc:=TEXTEXT.create
end;

{Lazarus Ext.}
{$IFDEF Windows}
type
   TStrS=class(TStrExpression)
             exp:TPrincipal;
          constructor create;
          destructor destroy;override;
      end;

constructor TStrS.create;
begin
    inherited create;
    check('(',IDH_STRING_FUNCTIONS);
    exp:=SExpression;
    check(')',IDH_STRING_FUNCTIONS);
end;

destructor TStrS.destroy;
begin
  exp.free;
  inherited destroy;
end;

type TNativeToUTF8=class(TStrS)
     function Code:AnsiString;override;
end;

type TUTF8ToNative=class(TStrS)
     function Code:AnsiString;override;
end;

function TNativeToUTF8.Code:ansistring;
begin
    result:='NativeToUTF8('+exp.code+')'
end;

function TUTF8ToNative.Code:ansistring;
begin
    result:='UTF8ToNative('+exp.code+')'
end;

function NativeToUtf8fnc:TPrincipal;
begin
   result:=TNativeToUTF8.create
end;

function Utf8ToNativefnc:TPrincipal;
begin
   result:=TUTF8ToNative.create
end;


function AnsiStringfnc:TPrincipal;
begin
   result:=TUTF8ToNative.create
end;

function ImportAnsifnc:TPrincipal;
begin
   result:=TNativeToUTF8.create
end;

type TUTF8ToWIDE=class(TStrS)
     function Code:AnsiString;override;
end;

type TWideToUtf8=class(TStrS)
     function Code:AnsiString;override;
end;

function TUTF8ToWide.Code:ansistring;
begin
    result:='Winlib.UTF8ToWide('+exp.code+')'
end;

function TWideToUTF8.Code:ansistring;
begin
    result:='Winlib.WideToUTF8('+exp.code+')'
end;

function UTF16Stringfnc:TPrincipal;
begin
   result:=TUTF8ToWide.create ;
end;

function ImportUTF16fnc:TPrincipal;
begin
   result:=TWideToUTF8.create ;
end;

{$ENDIF}

{**********}
{initialize}
{**********}
procedure FunctionTableInit;
begin
       SuppliedFunctionTableInit('STR$',STRfnc );
       SuppliedFunctionTableInit('CHR$',CHRfnc );
       SuppliedFunctionTableInit('REPEAT$',REPEATfnc );
       SuppliedFunctionTableInit('USING$',USINGfnc );
       SuppliedFunctionTableInit('LCASE$',LCASEfnc );
       SuppliedFunctionTableInit('UCASE$',UCASEfnc );
       SuppliedFunctionTableInit('LTRIM$',LTRIMfnc );
       SuppliedFunctionTableInit('RTRIM$',RTRIMfnc );
       SuppliedFunctionTableInit('BSTR$',BSTRfnc );
       ReservedWordTableInit('DATE$',DATEfnc );
       ReservedWordTableInit('TIME$',TIMEfnc );
       SuppliedFunctionTableInit('EXTEXT$',EXTEXTfnc );
       SuppliedFunctionTableInit('SUBSTR$',SubStrfnc );
       SuppliedFunctionTableInit('MID$',Midfnc );
       SuppliedFunctionTableInit('LEFT$',Leftfnc );
       SuppliedFunctionTableInit('RIGHT$',Rightfnc );
       {$IFDEF Windows}
       SuppliedFunctionTableInit('ANSI$',AnsiStringfnc );
       SuppliedFunctionTableInit('IMPORTANSI$',ImportAnsifnc );
       SuppliedFunctionTableInit('WIDE$',UTF16Stringfnc );
       SuppliedFunctionTableInit('IMPORTWIDE$',ImportUTF16fnc );
       {$ENDIF}
end;

begin
     tableInitProcs.accept(FunctionTableInit);
end.
