* new Unix demo: lister

demo/lister/flist.pas

@@ -0,0 +1,440 @@
+{
+    $Id$
+
+    This file is a Free Pascal example
+    Copyright (C) 2005 by Marco van de Voort
+        member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    A set of simple dirscanning routines for the lister.
+
+    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 FList;
+
+{$Mode Delphi}
+
+Interface
+
+Uses Classes{$ifdef Win32},Registry {$endif};
+
+Const NoMarkNoSelect=0;
+      MarkNoSelect  =1;
+      NoMarkSelect  =2;
+      MarkSelect    =3;
+
+Type
+
+     TDirList  = Class
+                  private
+                   ACursor,                 // Entry (0-based) the cursor is on.
+                   APosition,               // Entry (0-based) the homespot occupies
+                   ATotalEnt,               // Total number of entries (dirs.count+files.count)
+                   wdth,                    // width of a column (width of screen div col)+1 in chars
+                   Amaxent,                 // number of entries that fit on the screen
+                   Acolh,                   // height of a column in entries.
+                   botRightCol : Integer;   // When past this char, we are in bottombar
+                   TopBar,
+                   BottomBar   : Integer;   // lines below/above not for display
+
+                   AColumns    : Integer;  // amount of columns
+                   TheDirs     : TStringList;   // \
+                   TheFiles    : TStringList;   // The current entries
+                   Marked      : TBits;     // Which entries are selected?
+                   DirMax      : Integer;   // Can be used for autoscaling
+
+                   Filemax     : Integer;   // likewise
+                   ScrWidth,
+                   ScrHeight   : Integer;
+                   function  GetEntry(I:Integer;index:Integer):String;
+                   function  GetDirCount:Integer;
+                  public
+                   Directory   : String;    // Current dir we are looking at.
+                   Constructor Create;
+                   Destructor Destroy; override;
+                   Procedure PopulateList(Const FileSpec:String);
+                   Procedure CalcScreenStats;
+                   Procedure Mark(x:integer);
+                   Procedure UnMark(x:integer);
+                   Procedure Toggle(x:integer);
+                   {$ifdef Debug}
+                   Procedure PrintDirs;
+                   Procedure PrintFiles;
+                   {$endif}
+                   property Entries[i:Integer]:String index 0 read GetEntry; Default;
+                   property Directories[i:Integer]:String index 1 Read GetEntry;
+                   property Files[i:Integer]:String index 2 Read GetEntry;
+                   property DirCount:Integer read GetDirCount;
+                   property Position: Integer read APosition write APosition;
+                   property Columns: Integer read AColumns write AColumns;
+                   property Cursor: Integer read ACursor write ACursor;
+                   property Colh: Integer read AColh write AColh;
+                   property MaxEnt: Integer read AMaxEnt write AMaxEnt;
+                   property TotalEnt: Integer read ATotalEnt write ATotalEnt;
+                   End;
+
+
+    TVidDirList = Class(TDirList)
+                   {$ifdef Win32}
+                    Reg:TRegistry;
+                   {$endif}
+                   Attributes : Array[0..3] Of Integer;
+                   Constructor Create();
+                   Destructor Destroy; override;
+                   Procedure BuildDisplay;
+                   procedure ClearArea;
+                   Procedure Hilight(Curs,Home,Onx:Integer);
+                  {$ifdef Win32}
+                    Function CheckAssociation(ext:String):String;
+                  {$endif}
+                   End;
+
+
+Procedure TextOut(X,Y : Integer;Const S : String);
+Procedure textclear(x,y,Count :Integer);
+
+{$ifdef debug}
+var  f : Text;
+{$endif}
+
+
+Implementation
+
+Uses SysUtils,Video;
+
+// comes from vidutl in the video examples area.
+Procedure TextOut(X,Y : Integer;Const S : String);
+
+Var
+  P,I,M : Integer;
+
+begin
+  P:=((X-1)+(Y-1)*ScreenWidth);
+  M:=Length(S);
+  If P+M>ScreenWidth*ScreenHeight then
+    M:=ScreenWidth*ScreenHeight-P;
+  For I:=1 to M do
+    VideoBuf^[P+I-1]:=Ord(S[i])+($07 shl 8);
+end;
+
+Procedure textclear(x,y,Count :Integer);
+
+begin
+  FillWord(VideoBuf[((X-1)+(Y-1)*ScreenWidth)],count,$07 shl 8);
+end;
+
+
+Constructor TDirList.Create;
+
+Begin
+  TheDirs:=TStringList.Create;
+  TheFiles:=TStringList.Create;
+  Marked:=TBits.Create(1000);
+  TheDirs.Sorted:=True;
+  TheFiles.Sorted:=True;
+  TopBar:=1;
+  BottomBar:=1;
+  Columns:=4;
+  Inherited Create;
+End;
+
+function  TDirList.GetDirCount:Integer;
+
+Begin
+ Result:=TheDirs.Count;
+End;
+
+Destructor TDirList.Destroy;
+
+Begin
+ TheDirs.Free;
+ TheFiles.Free;
+ Marked.Free;
+ inherited destroy;
+End;
+
+Procedure TDirList.Mark(x:integer);
+
+Begin
+ Marked.Seton(x);
+End;
+
+Procedure TDirList.UnMark(x:integer);
+
+Begin
+ Marked.Clear(x);
+End;
+
+Procedure TDirList.Toggle(x:integer);
+
+{$ifdef Debug}
+var s:String;
+    I:longint;
+{$endif}
+
+Begin
+ Marked[x]:=NOT Marked[x];
+ {$ifdef Debug}
+ Writeln(F,'after marked:',marked.size);
+ SetLength(S,51);
+ For I:=0 To 50 Do
+  If Marked[i] Then
+   S[i+1]:=#49
+  else
+   S[I+1]:=#48;
+ TextOut(1,1,S);
+  Writeln(F,'after textout:',marked.size);
+ {$endif}
+End;
+
+Function TDirList.GetEntry(I:Integer;Index:Integer):String;
+
+Begin
+ {$ifdef Debug}
+  Writeln(F,'i:',i,' ',index);
+  {$endif}
+  Case Index Of
+  0 : If I<TheDirs.Count Then
+        Result:=TheDirs[I]
+      Else
+        Result:=TheFiles[I-TheDirs.Count];
+  1 : Result:=TheDirs[I];
+  2 : Result:=TheFiles[I];
+  End;
+End;
+
+Procedure TDirList.PopulateList;
+
+Var  Info : TSearchRec;
+     Len  : Integer;
+
+Procedure DoSearch(Const fs:String; Attr : Integer;AddFiles:Boolean);
+
+Begin
+    If FindFirst (Directory+FS,Attr,Info)=0 then
+      Repeat
+        Len:=Length(Info.Name);
+        If (Info.Attr and faDirectory) = faDirectory then
+          Begin
+            TheDirs.Add(Info.Name);
+            If Len>DirMax Then
+              DirMax:=Len;
+          End
+        Else
+          Begin
+            If AddFiles Then
+              Begin
+                TheFiles.Add(Info.Name);
+                If Len>FileMax Then
+                  FileMax:=Len;
+              End;
+          End;
+      Until FindNext(info)<>0;
+     FindClose(Info);
+End;
+
+Begin
+
+  DirMax:=0;
+  FileMax:=0;
+  TheDirs.Clear;
+  TheFiles.Clear;
+  Directory:=IncludeTrailingPathDelimiter(Directory);
+  If FileSpec='*.*' Then
+    Begin
+      DoSearch(FileSpec,faAnyFile and faDirectory,True);
+    End
+  Else
+    Begin
+      DoSearch('*.*',faDirectory,False);
+      DoSearch(FileSpec,faAnyFile,True);
+    End;
+  If (TheDirs.Count>0) And (TheDirs[0]='.') Then
+    TheDirs.Delete(0);
+  TotalEnt:=TheDirs.count+TheFiles.count;
+  Position:=0;
+  Cursor:=0;
+  If Marked.Size<TotalEnt THEN
+    Marked.Grow(TotalEnt);
+  Marked.ClearAll;
+End;
+
+{$ifdef debug}
+Procedure TDirList.PrintDirs;
+
+Var I:Integer;
+
+Begin
+  Writeln(f,Thedirs.count, ' ', thefiles.count, ' ',thedirs.count+thefiles.count);
+  If theDirs.Count>0 Then
+     For I:=0 To theDirs.Count-1 DO
+        Writeln(f,theDirs[I]);
+End;
+
+Procedure TDirList.PrintFiles;
+
+Var I:Integer;
+
+Begin
+  If TheFiles.Count>0 Then
+     For I:=0 To TheFiles.Count-1 DO
+        Writeln(f,TheFiles[I]);
+  Writeln(f,'----');
+End;
+{$endif}
+
+Procedure TDirList.CalcScreenStats;
+
+Begin
+ // Calc width of columns, minus one for the space inbetween
+
+ wdth:=(ScrWidth DIV Columns)-1;
+
+ // effective height of a column
+
+ colh:=(ScrHeight-TopBar-BottomBar);
+
+ // Max amount Filenames we can store in one screen;
+
+ maxent:=colh*Columns;
+
+ // If we write beyond this character, we would be wrong.
+
+ BotRightCol:=(ScrHeight-BottomBar)*ScrWidth;
+End;
+
+
+Constructor TVidDirList.Create;
+
+Begin
+ inherited Create;
+ ScrWidth:=ScreenWidth;
+ ScrHeight:=ScreenHeight;
+ CalcScreenStats;
+ {$Ifdef Win32}
+  Reg:=TRegistry.Create;
+  Reg.RootKey:=HKEY_CLASSES_ROOT;
+ {$endif}
+End;
+
+Destructor TVidDirList.Destroy;
+
+Begin
+ {$ifdef Win32}
+  Reg.Free;
+ {$endif}
+End;
+
+
+Procedure TVidDirList.BuildDisplay;
+
+Var
+  O,I,M,X,
+  TopLeftCol,
+  totalc,
+  lpos,
+  dirc       : Integer;
+  S       : String;
+
+begin
+ {$ifdef debug}
+//  Writeln(f,'entering');
+ {$endif}
+  dirc:=Thedirs.count;
+
+  totalc:=TotalEnt;
+  TopLeftCol:=TopBar*ScreenWidth;
+
+  X:=TopLeftCol;
+  lpos:=position+maxent;
+  // First the dirs;
+  i:=Position;
+  If I<Totalc THen
+   Begin
+     REPEAT
+       If I<dirc Then
+        S:=TheDirs[I]
+       Else
+        S:=TheFiles[I-dirc];
+       m:=Length(s);
+       if m>wdth Then
+        m:=wdth;
+
+       For o:=0 to m-1 do
+        VideoBuf^[X+O]:=Ord(S[o+1])+(Attributes[ORD(Marked[I])] shl 8);
+
+       inc(X,screenwidth);
+       If X>=botrightcol Then
+        Begin
+         TopLeftCol:=TopLeftCol+wdth+1;
+         x:=TopLeftCol;
+        End;
+     Inc(I);
+     Until (i>=lpos) or (I>=totalc);
+     {$ifdef debug}
+//     Writeln(F,'lpos  :',lpos);
+//     writeln(F,'i     :',i);
+//     writeln(F,'totalc:',totalc);
+     {$endif}
+   End;
+end;
+
+Procedure TVidDirList.Hilight(Curs,Home:Integer;Onx:Integer);
+
+Var I    : Integer;
+    Posx : Integer;
+    L    : PWord;
+    Attr : Integer;
+
+Begin
+ Attr:=Attributes[ORD(Marked[Curs])+Onx shl 1] shl 8;
+ Posx:=Curs-Home;
+ L:=@VideoBuf[(Posx DIV Colh)*(wdth+1) + (TopBar+ Posx MOD Colh)*screenWidth];
+ For I:= 0 TO wdth-1 DO
+  Begin
+   L^:=(L^ And 255) + Attr;
+   Inc(L);
+  End;
+End;
+
+procedure TVidDirList.ClearArea;
+Begin
+    TextClear(1,2,screenwidth*(screenheight-topbar-bottombar));
+End;
+
+{$ifdef Win32}
+ Function TVidDirList.CheckAssociation(ext:String):String;
+
+ Var S : String;
+ Begin
+  if Reg.OpenKey(ext, false) then
+   begin
+     Reg.CloseKey;
+     Reg.Free;
+     Exit('');
+   end;
+
+  Reg.OpenKey('\'+ext, True);
+  S:=Reg.readString('');
+
+  Reg.OpenKey('\'+S+'\Shell\Open\Command', True);
+  Result:=Reg.ReadString('');
+ End;
+{$endif}
+end.
+
+{
+  $Log$
+  Revision 1.1  2005-04-06 08:54:16  marco
+   * new Unix demo: lister
+
+}

demo/lister/lister.pas

@@ -0,0 +1,274 @@
+{
+    $Id$
+
+    This file is a Free Pascal example
+    Copyright (C) 2005 by Marco van de Voort
+        member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    An filebrowser inspired by Vernon D. Buerg's list.com, designed
+    to be a shell to less under Unix, but works fine under Windows too.
+    (using any less and file in the path)
+
+    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 Delphi}
+
+Uses Process,SysUtils,Video,Keyboard,FList
+     {$IFDEF UNIX}, BaseUnix{$ENDIF};
+
+Function Do_File_cmd(path:String):String;
+
+Const BufSize = 1024;
+
+      TheProgram = 'file' {$IFDEF Win32}+'.exe' {$ENDIF};
+
+
+Var S : TProcess;
+    Buf : Array[1..BUFSIZE] of char;
+    I,Count : longint;
+
+
+begin
+  S:=TProcess.Create(Nil);
+  S.Commandline:=theprogram+' '+path;
+  S.Options:=[poUsePipes,poNoConsole];
+  S.execute;
+  Result:='';
+  Count:=s.output.read(buf,BufSize);
+  If Count>0 Then
+    Begin
+      SetLength(Result,Count);
+      Move(buf[1],Result[1],Count);
+    End;
+  S.Free;
+  {$ifdef win32}
+  If Length(Result)>2 Then
+   Begin
+    If Result[2]=':' Then
+     Result[2]:=' ';
+   End;
+  {$endif}
+  i:=Pos(':',Result);
+  If I>0 Then
+    Delete(Result,1,I);
+  Result:=Trim(Result);
+  I:=Length(Result);
+  While (I>0) and (Result[I]=#10) DO
+   Dec(I);
+  If I>ScreenWidth Then
+    I:=ScreenWidth;
+  SetLength(Result,I);
+end;
+
+
+Var
+  FileSpec : String;
+  D        : TVidDirList;
+  ExitNow  : Boolean;
+  K        : TKeyEvent;
+  OldHome,
+  OldCursor: Integer;
+  S,S2     : String;
+  Forced,
+  ForcedFull: Boolean;
+  C        : Char;
+  Pager : AnsiString;
+Procedure ReDraw;
+
+Begin
+    D.ClearArea;
+    D.BuildDisplay;
+    D.HiLight(D.Cursor,D.Position,1);
+    // Probably so much changed that diffing won't help?
+    UpdateScreen(true);
+End;
+
+
+Begin
+  InitVideo;
+  InitKeyboard;
+  {$ifdef Unix}
+   FileSpec:='*';
+  {$else}
+   FileSpec:='*.*';
+  {$endif}
+  ExitNow:=False;
+  {$ifdef win32}
+   Pager:='notepad.exe';
+  {$else}
+   Pager:=GetEnvironmentVariable('PAGER'); 
+   if Pos('/',Pager)=0 Then
+     Pager:=FileSearch(Pager,GetEnvironmentVariable('PATH'));
+  {$endif}
+
+  If ParamCount()>0 Then
+    FileSpec:=ParamStr(1);
+  {$ifdef debug}
+  assign(f,'log.txt');
+  rewrite(F);
+  {$endif}
+  D:=TVidDirList.Create;
+  D.Columns:=5;                              // default
+  D.Directory:=GetCurrentDir;
+  D.PopulateList(FileSpec);
+  D.Attributes[NoMarkNoSelect]:=$07;
+  D.Attributes[MarkNoSelect]  :=$17;
+  D.Attributes[NoMarkSelect]  :=$0F;
+  D.Attributes[MarkSelect]    :=$1F;
+
+  ReDraw;
+  Repeat
+   {$ifdef debug}
+    Writeln(F,'Cursor  :',D.Cursor);
+    Writeln(F,'Position:',D.Position);
+    Writeln(F,'Totalent:',D.TotalEnt);
+//    Writeln(F,'wdth    :',D.wdth);
+    Writeln(F,'maxent  :',D.maxent);
+    Writeln(F,'colh    :',D.colh);
+    Writeln(F,'columns :',D.columns);
+    Writeln(F);
+   {$endif}
+
+    K:=GetKeyEvent;
+    K:=TranslateKeyEvent(K);
+    OldCursor:=D.Cursor;
+    OldHome:=D.Position;
+    Forced:=False;
+    ForcedFull:=False;
+    IF IsFunctionKey(K) Then
+      Begin
+        K:=TKeyRecord(K).KeyCode;
+        Case K Of
+          kbdRight: Begin
+                     If D.Cursor<(D.TotalEnt-D.Colh) Then
+                       D.Cursor:=D.Cursor+D.colh
+                      else
+                       D.Cursor:=D.TotalEnt-1;
+                     If D.Cursor>=(D.Position+D.MaxEnt) Then
+                      D.Position:=D.Position+d.colh;
+                    End;
+          kbdDown : Begin
+                     If D.Cursor<(D.TotalEnt-1) Then
+                      D.Cursor:=D.Cursor+1;
+                     If D.Cursor>(D.Position+D.MaxEnt-1) Then
+                      D.Position:=D.Position+D.Colh;
+                    End;
+          kbdUp   : Begin
+                     If D.Cursor>0 Then
+                      D.Cursor:=D.Cursor-1;
+                     If D.Cursor<D.Position Then
+                       Begin
+                         D.Position:=D.Position-D.Colh;
+                         If D.Position<0 Then
+                          D.Position:=0;
+                       End;
+                    End;
+          kbdLeft : Begin
+                     If D.Cursor>=(D.Colh) Then
+                        D.Cursor:=D.Cursor-D.colh
+                      else
+                        D.Cursor:=0;
+                     If D.Cursor<D.Position Then
+                       D.Position:=D.Position-D.Colh;
+                     If D.Position<0 Then
+                       D.Position:=0;
+                    End;
+          End;
+      End
+    Else
+      Begin
+        C:=GetKeyEventChar(K);
+        if C<>#0 Then
+        Case C Of
+          #13      : Begin
+                       If D.Cursor>=D.DirCount Then
+                         Begin
+                           S:=ExtractFileExt(D[D.Cursor]);
+                           Delete(S,1,1);
+                           ExecuteProcess(Pager,[D.Directory+D[D.Cursor]]);
+                           // TextOut(10,1,'                        ');
+                           //TextOut(10,1,D[D.Cursor]);
+                           ForcedFull:=True;
+                         End
+                       Else
+                         Begin
+                           S:=D.Directories[D.Cursor];
+                           S2:=D.Directory+S;
+                           If S='..' Then
+                             S2:=ExpandFileName(S2);
+			   {$IFDEF UNIX}
+                           IF FPAccess(pchar(s2),X_OK)=0 Then
+                             begin
+		           {$ENDIF}
+                               D.Directory:=S2;
+                               D.PopulateList(FileSpec);
+                               ForcedFull:=True;
+ 			   {$IFDEF UNIX}
+                             end;
+			   {$ENDIF}
+                         End;
+                     End;
+          #27,'q'  : exitnow:=True;
+          ' '      : Begin
+                       D.Toggle(D.Cursor);
+                       Forced:=True;
+                     End;
+          'i'      : Begin
+                       TextClear(1,1,ScreenWidth);
+                       If D.Cursor>=D.DirCount Then
+                         Begin
+                           TextOut(1,1,do_file_cmd(' '+D.Directory+D[D.Cursor]));
+                         End
+                       Else
+                         Begin
+                           textout(1,1,+' is a directory');
+                         End;
+                      Forced:=True;
+                     End;
+
+          End;
+      End;
+
+   // Determine if, and what kind of updating necessary;
+   If (OldHome<>D.Position) OR ForcedFull Then
+     Redraw
+   Else
+     Begin
+      If (OldCursor<>D.Cursor) Or Forced Then
+        Begin
+          D.Hilight(OldCursor,OldHome,0);
+          D.HiLight(D.Cursor,D.Position,1);
+          UpdateScreen(False);
+        End;
+     End;
+  Until ExitNow;
+
+  DoneKeyboard;
+  DoneVideo;
+  {$ifdef Debug}
+  d.printdirs;
+  d.printfiles;
+  {$endif}
+  D.Free;
+
+  {$ifdef debug}
+  Close(F);
+  {$endif}
+End.
+
+{
+   $Log$
+   Revision 1.1  2005-04-06 08:54:16  marco
+    * new Unix demo: lister
+
+}