Quelle OwnUtils.old.pas Sprache: Delphi

unit OwnUtils;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
interface
uses
  //----------------------------------------------------------------------------
  //local
  //----------------------------------------------------------------------------
  GenDefs,mysql,Utilities,language,
  //----------------------------------------------------------------------------
  //global
  //----------------------------------------------------------------------------
  ComCtrls,ExtCtrls,Graphics,Forms,Types;
//----------------------------------------------------------------------------
//
//----------------------------------------------------------------------------
const
{$I OwnConsts.inc}
  //----------------------------------------------------------------------------
  //
  //----------------------------------------------------------------------------
type
{$I OwnTypes.inc}
  //----------------------------------------------------------------------------
  //
  //----------------------------------------------------------------------------
function GetSecrets(Installkey:JString;SK:JString;ProductNumber:char):integer;
procedure SetSecrets(Installkey:JString;V:integer;ProductNumber:char);
Procedure DefaultOptions(var Opt:OwnOptions);
procedure setl(var a: array of char;S:JString);
function empty(P:PAnsiChar;V:ViewData):boolean;
function TreeHide(var TS:TTReeView):PLongTexts;
function InSight(var P:ViewData):boolean;
function Longeur(PL:PLongTexts;Tx:TTreeNode):JString;
procedure Statusline(PC:TPageControl;Opt:OwnOptions;var SB:TStatusBar;
  Tip:JString);
function dllcall(var Opt:OwnOptions;var Libraries:AnsiString;
  Path,Source:JString;var lexlang:integer;var CNav,CFA,DFA,CSem,CMes,
  CFun,Attr:PAnsiChar;var Coldef:integer;Edition:JString;
  var status:PAnsiChar;var dllinfo:PAnsiChar;var warnings:integer):integer;
function netallowed:boolean;
function MouseOver(Fr:Frames;Opt:OwnOptions):boolean;
function GetNextRec(TC:PAnsiChar):JString;
procedure OpenStream(TC:PAnsiChar);
//----------------------------------------------------------------------------
//Global Vars
//----------------------------------------------------------------------------
var
  MDI:Document;
  InitialMemory:longint;
  Lizenzmeldung:boolean;
  Opening,Closing:boolean;
  Loading,Splitting:boolean;
  Inspectorkey:JString;
  DiskDrive:JString;
  SourceInfo:JString24;
  DiskType:integer;
  Filters:JString;
  Dom: array [0..2] of char;
  ViewList: TFrameState;
  AD: array of AllDll;
  ADHandle: array of THandle;
  Extensions: array of LangType;
  Createbackup:boolean;
  netflag:boolean;
  Title:JString;
  ColumboFileName:JString;
  BatchRun,Recursive:boolean;
  PrettyPrint:boolean;
  ShowPrettyPrint:boolean;
  Im_Root,Im_Branch,Im_Level,Im_State,im_Error:integer;
  P6,P7:PChar;
  VerticeStack: array of integer;
  VerticeStp:integer;
  lev,lastlev,offs:integer;
  next,count:integer;
  eofs:boolean;
  LastMousePos:TPoint;
  //----------------------------------------------------------------------------
  //
  //----------------------------------------------------------------------------
implementation
uses
  //----------------------------------------------------------------------------
  //specific
  //----------------------------------------------------------------------------
  Messages,SysUtils,Variants,Classes,Controls,Dialogs,StdCtrls,jpeg,
  StrUtils,WinSock,Registry,ShellAPI,Math,DateUtils,Windows
{$I Indy.inc}
  ;
//------------------------------------------------------------------
//framestate
//
//------------------------------------------------------------------
constructor TFRameState.create();
var fr:Frames;
begin
  next:=nil;
  Previous:=nil;
  for FR:=F1 to F3 do
   st[FR].ActiveView:=NoView;
end;
//------------------------------------------------------------------
//test if net allowed
//
//------------------------------------------------------------------
function netallowed:boolean;
begin
  if not netflag then
    netflag:=ask(140,'In das Internet gehen?');
  result:=netflag
end;
//------------------------------------------------------------------
//Procedure Setl
//moving of short arrays
//------------------------------------------------------------------
procedure setl(var a: array of char;S:JString);
var
  i:integer;
begin
  for i:=0 to length(a)-1 do
    a[i]:=chr(0);
  i:=0;
  if length(S)>=sizeof(a) then
    errorn(101,'fataler Fehler')
  else
    while (i<length(S))and(i<sizeof(a)) do begin
      a[i]:=S[i+1];
      i:=i+1
    end;
end;
//-----------------------------------------------------------------
//function dllcall
//set Options.R.
//-----------------------------------------------------------------
function dllcall(var Opt:OwnOptions;var Libraries:AnsiString;
  Path,Source:JString;var lexlang:integer;var CNav,CFA,DFA,CSem,CMes,
  CFun,Attr:PAnsiChar;var Coldef:integer;Edition:JString;
  var status:PAnsiChar;var dllinfo:PAnsiChar;var warnings:integer):integer;
var
  rv:integer;
  ext:JString;
  Libs: array [0..2047] of char;
  PLibs:PAnsiChar;
  ret,lib:JString;
  i,hand:integer;
begin
  if length(Libraries)+length(Path)+length(Source)-8>=2048 then begin
    showmessage(trans(lang,52,'Lib zu lang'));
    ExitProcess(100);
  end;
  ret:=chr(Key_LineFeed);
  PLibs:=@Libs;
  StrCopy(PLibs,PAnsiChar(AnsiString(Source)+AnsiString(ret)+AnsiString(Path)
        +AnsiString(ret)+AnsiString(Libraries)));
  ext:=ExtractFileExt(Source);
  ext:=Lowercase(ext);
  //find right record
  hand:=-1;
  for i:=0 to length(Extensions)-1 do begin
    if pos(ext,Extensions[i].ext)>0 then
      hand:=i;
  end;
  rv:=99;
  if hand<0 then
    errorn(102,'falsche Extension der Datei')
  else
    try
      lib:=Opt.ProgramDir+Extensions[hand].dllname;
      if (ADHandle[hand]=0)and(Fileexists(lib)) then
        ADHandle[hand]:=LoadLibrary(PChar(lib));
      if ADHandle[hand]<>0 then begin
        @AD[hand]:=GetProcAddress(ADHandle[hand],
          PChar(Extensions[hand].entrypoint));
        rv:=AD[hand](PLibs,lexlang,CNav,CFA,DFA,CSem,CMes,CFun,Attr,Coldef,
          PAnsiChar(AnsiString(Edition)),status,dllinfo,warnings)
      end
      else begin
        errorn(103,'Bibliothek für '+Extensions[hand].dllname+
            '-Dateien nicht vorhanden');
        rv:=99;
      end
      except
        on E:Exception do begin
          errorn(104,E.Message);
          rv:=911;
        end
        else begin
          errorn(105,'Bibliothek für '+Extensions[hand].dllname+
              '-Dateien nicht vorhanden');
          rv:=99;
        end
      end;
      Libraries:=PLibs;
      dllcall:=rv;
    end;
  //----------------------------------------------------------------
  //Hide long texts in Tree
  //
  //----------------------------------------------------------------
  function TreeHide(var TS:TTReeView):PLongTexts;
  var
    T:PLongTexts;
    tt:TTreeNode;
    i:integer;
    MaxWidth:integer;
  begin
    new(T);
    SetLength(T^.items,TS.items.count);
    TS.items.BeginUpdate;
    tt:=TS.TopItem;
    i:=0;
    MaxWidth:=0;
    while not(tt=nil) do begin
      T^.items[i].Ptr:=tt;
      //catcher(i=321);
      setl(T^.items[i].Text,tt.Text);
      tt.Text:=Functor(tt.Text);
      tt.Text:=StringReplace(tt.Text,'\\','\',[rfReplaceAll]);
      tt.Text:=StringReplace(tt.Text,'\\','\',[rfReplaceAll]);
      if tt.Level<3 then
        MaxWidth:=max(length(tt.Text),MaxWidth);
      tt:=tt.GetNext;
      i:=i+1;
    end;
    TS.items.EndUpdate;
    TreeHide:=T;
  end;
  //----------------------------------------------------------------
  //get long text of Treenode
  //
  //----------------------------------------------------------------
  function Longeur(PL:PLongTexts;Tx:TTreeNode):JString;
  var
    i:integer;
    Tn:TTreeNode;
    ll:integer;
  begin
    Longeur:='';
    if PL<>nil then begin
      ll:=length(PL^.items)-1;
      for i:=0 to ll do begin
        Tn:=PL^.items[i].Ptr;
        if Tn=Tx then
          Longeur:=PL^.items[i].Text;
      end
    end;
  end;
  //-----------------------------------------------------------------
  //function setsecrets                                          -
  //-
  //-----------------------------------------------------------------
  procedure SetSecrets(Installkey:JString;V:integer;ProductNumber:char);
  begin
    if DiskType<>DRIVE_REMOVABLE then begin
      SetSecretRegistryValue(Installkey,V,AnsiChar(ProductNumber));
      SetSecretFile(Installkey,V,ProductNumber);
    end;
  end;
  //-----------------------------------------------------------------
  //function setsecrets                                          -
  //-
  //-----------------------------------------------------------------
  function GetSecrets(Installkey:JString;SK:JString;ProductNumber:char):integer;
  var
    r1,r2:integer;
  begin
    r2:=-1;
    if DiskType<>DRIVE_REMOVABLE then begin
      r1:=GetSecretRegistryValue(Installkey,ProductNumber);
      r2:=GetSecretFile(Installkey,SK,ProductNumber);
      if r1<>r2 then
        r2:=-1;
    end;
    GetSecrets:=r2
  end;
  //-----------------------------------------------------------------
  //DEefault input                                               -
  //-----------------------------------------------------------------
  function getdefaultfile():JString;
  var
    f:JString;
  begin
    f:=GetCurrentDir+'\'+'workspace\hallo.cbl';
    if not Fileexists(f) then
      f:=GetCurrentDir+'\'+'workspace\hallo.bat';
    getdefaultfile:=f;
  end;
  //-----------------------------------------------------------------
  //Create Tabsheet                                              -
  //-----------------------------------------------------------------
  function empty(P:PAnsiChar;V:ViewData):boolean;
  begin
    if P=nil then
      empty:=true
    else if length(P)=0 then
      empty:=true
    else if V.Sheet.PageControl=nil then
      empty:=true
    else
      empty:=false
  end;
  //-----------------------------------------------------------------
  //Tabsheet visible?                                            -
  //-----------------------------------------------------------------
  function InSight(var P:ViewData):boolean;
  begin
    if not(P.Frame in [F1..F3]) then
      InSight:=false
    else if P.Sheet=nil then
      InSight:=false
    else if not P.Sheet.visible then
      InSight:=false
    else if P.Sheet.PageControl=nil then
      InSight:=false
    else if P.Sheet.Width<10 then
      InSight:=false
    else if P.Sheet.Height<10 then
      InSight:=false
    else
      InSight:=P.Sheet=P.Sheet.PageControl.ActivePage;
  end;
  //------------------------------------------------------------------
  //--
  //get next Record in Streamn/String                            --
  //--
  //------------------------------------------------------------------
  function GetNextRec(TC:PAnsiChar):JString;
  var
    S:JString;
  begin
    next:=offs;
    lastlev:=lev;
    lev:=0;
    while (TC[next]=chr(9))and(next<=Length(TC)) do begin
      lev:=lev+1;
      next:=next+1;
    end;
    S:='';
    while (TC[next]>chr(15))and(next<=length(TC)) do begin
      S:=S+String(TC[next]);
      next:=next+1;
    end;
    eofs:=(TC=nil)or(TC='')or(TC[next]=chr(0))or(TC[next+1]=chr(0));
    offs:=next+1;
    count:=count+1;
    GetNextRec:=S;
  end;
  //------------------------------------------------------------------
  //--
  //open Stream/String                                           --
  //--
  //------------------------------------------------------------------
  procedure OpenStream(TC:PAnsiChar);
  begin
    offs:=0;
    eofs:=false;//Reset Stream
    count:=0;
    lev:=0;
    lastlev:=0;//Reset Tree
  end;
  //-----------------------------------------------------------------
  //Tabsheet visible?                                            -
  //-----------------------------------------------------------------
  function MouseOver(Fr:Frames;Opt:OwnOptions):boolean;
  var
    PC:TPageControl;
    f:TFrame;
    MF:TForm;
  begin
    PC:=nil;
    if Fr=Opt.Navigator.Frame then
      PC:=Opt.Navigator.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Semantik.Frame then
        PC:=Opt.Semantik.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Explorer.Frame then
        PC:=Opt.Explorer.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Source.Frame then
        PC:=Opt.Source.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.CFA.Frame then
        PC:=Opt.CFA.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.DFA.Frame then
        PC:=Opt.DFA.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Measures.Frame then
        PC:=Opt.Measures.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Funktion.Frame then
        PC:=Opt.Funktion.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Miniatur.Frame then
        PC:=Opt.Miniatur.Sheet.PageControl;
    if PC=nil then
      if Fr=Opt.Druckvorschau.Frame then
        PC:=Opt.Druckvorschau.Sheet.PageControl;
    f:=(PC.Parent as TFrame);
    MF:=(f.Parent as TForm);
    MouseOver:=(Mouse.CursorPos.x>=MF.left+f.left+PC.left)and
      (Mouse.CursorPos.x<=MF.left+f.left+PC.left+PC.Width)and
      (Mouse.CursorPos.y>=MF.top+f.top+PC.top)and
      (Mouse.CursorPos.y<=MF.top+f.top+PC.top+PC.Height)
  end;
  //-----------------------------------------------------------------
  //Tabsheet visible?                                            -
  //-----------------------------------------------------------------
  procedure Statusline(PC:TPageControl;Opt:OwnOptions;var SB:TStatusBar;
    Tip:JString);
  var
    vissheet:TTabSheet;
    Fr:Frames;
    st,M,SN,TD,S,SI:JString;
  begin
    SN:='';
    S:='';
    SI:='';
    Fr:=F1;
    vissheet:=PC.ActivePage;
    if Opt.language=english then begin
      if vissheet=Opt.Navigator.Sheet then
        SN:='Navigator'
      else if vissheet=Opt.Semantik.Sheet then
        SN:='Semantics'
      else if vissheet=Opt.Explorer.Sheet then
        SN:='Explorer'
      else if vissheet=Opt.Source.Sheet then
        SN:='Source'
      else if vissheet=Opt.CFA.Sheet then
        SN:='Cfa'
      else if vissheet=Opt.DFA.Sheet then
        SN:='Dfa'
      else if vissheet=Opt.Measures.Sheet then
        SN:='Measures'
      else if vissheet=Opt.Funktion.Sheet then
        SN:='Function'
      else if vissheet=Opt.Miniatur.Sheet then
        SN:='Miniatur'
      else if vissheet=Opt.Druckvorschau.Sheet then
        SN:='Printpreview';
    end
    else begin
      if vissheet=Opt.Navigator.Sheet then
        SN:='Navigator'
      else if vissheet=Opt.Semantik.Sheet then
        SN:='Semantik'
      else if vissheet=Opt.Explorer.Sheet then
        SN:='Explorer'
      else if vissheet=Opt.Source.Sheet then
        SN:='Quelle'
      else if vissheet=Opt.CFA.Sheet then
        SN:='Cfa'
      else if vissheet=Opt.DFA.Sheet then
        SN:='Dfa'
      else if vissheet=Opt.Measures.Sheet then
        SN:='Maße'
      else if vissheet=Opt.Funktion.Sheet then
        SN:='Funktion'
      else if vissheet=Opt.Miniatur.Sheet then
        SN:='Miniatur'
      else if vissheet=Opt.Druckvorschau.Sheet then
        SN:='Druckvorschau';
    end;
    if vissheet=Opt.Navigator.Sheet then
      Fr:=Opt.Navigator.Frame
    else if vissheet=Opt.Semantik.Sheet then
      Fr:=Opt.Semantik.Frame
    else if vissheet=Opt.Explorer.Sheet then
      Fr:=Opt.Explorer.Frame
    else if vissheet=Opt.Source.Sheet then
      Fr:=Opt.Source.Frame
    else if vissheet=Opt.CFA.Sheet then
      Fr:=Opt.CFA.Frame
    else if vissheet=Opt.DFA.Sheet then
      Fr:=Opt.DFA.Frame
    else if vissheet=Opt.Measures.Sheet then
      Fr:=Opt.Measures.Frame
    else if vissheet=Opt.Funktion.Sheet then
      Fr:=Opt.Funktion.Frame
    else if vissheet=Opt.Miniatur.Sheet then
      Fr:=Opt.Miniatur.Frame
    else if vissheet=Opt.Druckvorschau.Sheet then
      Fr:=Opt.Druckvorschau.Frame;
    if Opt.InspectorVisible and(Fr=F1) then
      SN:=SN+'+ Inspector';
    if Opt.Source.Sheet=vissheet then begin
      S:=SN+' '+ExtractFileName(Opt.Actfile)+' ';
      if st>'' then
        M:='['+st+']';
      S:=S+' '+M;
      SI:=SourceInfo;
    end
    else begin
      if InSight(Opt.Source) then
        S:=S+M+TD
      else
        S:=S+TD;
      S:=SN+' '+ExtractFileName(Opt.Actfile);
    end;
    SB.SimpleText:=S+SI+' '+Tip;
  end;
  //-----------------------------------------------------------------
  //Procedure DefaultOptions                                         -
  //set Options                                                  -
  //-----------------------------------------------------------------
  Procedure DefaultOptions(var Opt:OwnOptions);
  var
    i:integer;
    FC:JString;
  begin
    for i:=0 to maxoptsize do
      Opt.cc[i]:=chr(0);
    setl(Opt.homeDir,ExtractFilePath(Optionsfilename(Title)));
    setl(Opt.ProgramDir,ExtractFilePath(ParamStr(0)));
    setl(Opt.RemoteDir,Opt.ProgramDir+RemoteDirectory);
    setl(Opt.ExecDir,Opt.ProgramDir+ExecDir);
    FC:=Opt.ProgramDir+'compilebatch.bat';
    if not Fileexists(FC) then
      FC:='';
    setl(Opt.CommandFile,FC);
    setl(Opt.ExportDir,GetCurrentDir);
    Opt.ExportEnabled:=false;
    //-----------------------------------------------------------------------------
    //Licensing  //
    //-----------------------------------------------------------------------------
    Opt.Activated:=false;
    Opt.FirstUse:=DateOf(Now);
    Opt.LastUse:=DateOf(Now);
    Opt.DaysEffectivlyUsed:=0;
    Opt.DaysUsed:=0;
    if DiskType<>DRIVE_REMOVABLE then
      setl(Opt.SecretKey,SetSecretRegistryValue(Installkey,0,ProductNumber));
    if (Title=Title_Columbo) then
      Opt.Edition:=Shareware
    else if (Title=Title_Elbe) then
      Opt.Edition:=Shareware;
    //
    Opt.inited:=' ';
    Opt.privileged:=' ';
    Opt.BackgroundColor:=clWhite;
    Opt.ButtonSize:=5;
    Opt.FontName:='Courier New';
    Opt.FontSize:=9;
    Opt.drawgrid:=false;
    if Screen.Width>(3*Screen.Height)div 2 then begin
      Opt.Width:=11*Screen.Width div 32;
      Opt.Height:=3*Screen.Height div 4;
    end
    else begin
      Opt.Width:=21*Screen.Width div 32;
      Opt.Height:=3*Screen.Height div 4;
    end;
    Opt.top:=(Screen.Height)div 8;
    Opt.left:=(Screen.Width div 2)-(Opt.Width div 2);
    Opt.ismax:=false;
    //DefaultFrames;
    Opt.frame1Page1Max:=false;
    Opt.frame1Page2Max:=false;
    Opt.frame2Page1Max:=false;
    Opt.Frame3Page1Max:=false;
    //source options
    Opt.SyntaxHighlight:=true;
    Opt.SyntaxBold:=false;
    Opt.ShowSpaces:=false;
    Opt.Columnumbers:=false;
    Opt.Linenumbers:=false;
    Opt.Blocknumbers:=false;
    Opt.Sourceformat:=FixedFormat;
    Opt.Highlites[H_keyword]:=clblue;
    Opt.Highlites[H_String]:=clred;
    Opt.Highlites[H_Numeric]:=clMaroon;
    Opt.Highlites[H_Identifier]:=clblack;
    Opt.Highlites[H_Foreignkeyword]:=clNavy;
    Opt.Highlites[H_Comment]:=clgreen;
    Opt.Highlites[H_Foreignidentifier]:=clgray;
    Opt.Highlites[H_Label]:=clPurple;
    Opt.Highlites[H_Lexelem]:=clFuchsia;
    Opt.Coldefine:=false;
    Opt.InternetAllowed:=false;
    //input files
    Opt.LastFilter:='.cob';
    setl(Opt.Libraries[1],Opt.ProgramDir+'workspace\'+CopyLib);
    for i:=2 to 3 do
      Opt.Libraries[i]:='';
    for i:=1 to HistMax do
      Opt.HistoryFile[i]:='';
    for i:=1 to HistMax do
      Opt.HistoryCount[i]:=0;
    for i:=1 to HistMax do
      Opt.HistoryDateTime[i]:=Now;
    for i:=1 to HistMax do begin
      Opt.HistoryPosition[i][F1].ActiveView:=ViewNav;
      Opt.HistoryPosition[i][F2].ActiveView:=ViewSource;
      Opt.HistoryPosition[i][F3].ActiveView:=NoView;
    end;
    for i:=1 to length(Opt.FillUp) do
      Opt.FillUp[i]:=Random;
    setl(Opt.Infile,getdefaultfile());
    Opt.Actfile:='';
    setl(Opt.WindowsProductId,GetWinProductId);
    Opt.FuncHelp:=Key_F1;
    Opt.FuncSearch:=Key_F3;
    Opt.FuncReplace:=Key_F4;
    Opt.FuncContReplace:=Key_F5;
    Opt.FuncHelp:=Key_F1;
    Opt.Frame1Width:=Opt.Width div 4;
    Opt.ThumbnailWidth:=Opt.Width div 4;
    Opt.Frame3Height:=Opt.Height div 3;
    Opt.InspectorHeight:=(Opt.Height-Borderwidth)div 3;
    Opt.InspectorVisible:=true;
    Opt.LineThickness:=1;
    Opt.EndofOpts:=true;
    Opt.Navigator.Frame:=F1;
    Opt.Semantik.Frame:=F1;
    Opt.Explorer.Frame:=F1;
    Opt.Source.Frame:=F2;
    Opt.CFA.Frame:=F2;
    Opt.DFA.Frame:=F2;
    Opt.Measures.Frame:=F2;
    Opt.Funktion.Frame:=F2;
    Opt.Miniatur.Frame:=F3;
    Opt.Druckvorschau.Frame:=F3;
    Opt.Createbackup:=false;
    Opt.language:=german;
    Opt.Timeout:=10;
    if Fileexists(Opt.ProgramDir+'english.txt') then
      Opt.language:=english;
    //now generate check sums
    if length(Extensions)>0 then begin
      Opt.CobolDllLen:=getFileLength(Extensions[1].dllname);
      Opt.CobolDllSum:=getFileSum(Extensions[1].dllname);
      Opt.ColumboLen:=getFileLength(ColumboFileName);
      Opt.ColumboSum:=getFileSum(ColumboFileName);
      Opt.ColumboDate:=getFileAge(ColumboFileName);
    end;
  end;
end.

quality93%

¤ Dauer der Verarbeitung: 0.30 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.