Amiga ISO Collection/AmigaUtilCD2.iso/Programming/Pascal/HISOFTPASCAL2,0-2.DMS/in.adf/Extras/FileRequest.pas

Pascal/Delphi Source File | 1992-05-21 | 6.0 KB | 224 lines

(*    FileRequest.pas
 *        An example program which shows how to use the ASL and ARP file
 *        requesters from a HighSpeed Pascal program.  It also illustrates
 *        some methods of string conversion, handling of path names, the
 *        XASSEMBLER keyword, use of 'tags' from Pascal and a way of
 *        implementing function calls via pointers.
 *
 *        Written by Keith Wilson, HiSoft.
 *)

program FileRequest;
{ ARP.unit and some 2.0 units are required to compile this }
{ so you will have to set up your Units Path accordingly }
uses Amiga, AmigaDOS, ARP, ASL, Exec, Intuition, Utility;


const
{ required library versions }
    ASL_REV = 36;
    ARP_REV = 33;


(*    SplitName extracts the directory and filename components of an
 *    AmigaDOS pathname.  It is similar to FSplit in the DOS unit but
 *    handles up to 255 character names.
 *)

procedure SplitName (path: string; var dir, name: string);
var i: integer;
begin
    i := Length(path);
    repeat
        dec(i)
    until (i = 0) or (path[i] = ':') or (path[i] = '/');
    name := Copy(path, i+1, Length(path)-i);

    if dir[i] = '/' then dec(i);    { don't give a trailing slash }
    dir := Copy(path, 1, i)
end;


(*    You should use this routine to glue a directory and filename back
 *    together.  It automatically adds a slash separator if necessary.
 *)

procedure AddName (var dir: string; name: string);
var c: char;
begin
    c := dir[Length(dir)];
    if (c <> #0) and (c <> ':') and (c <> '/') then dir := dir + '/';
    dir := dir + name;
end;


(*    This function turns any Pascal string into a C string by adding
 *    a null to the end and returning a pointer to the first character.
 *    Note that the string can still be used as a Pascal string.
 *)

function NullTerm (var s: string): STRPTR;
var i: integer;
begin
    i := Length(s) + 1;
    if i > 255 then
    begin
        Delete(s, 255, 1);        { ensure there is a spare byte }
        Dec(i)
    end;
    s[i]     := #0;
    NullTerm := @s[1]
end;


(*    To make a Pascal string from a C string which starts at s[1], we
 *    fool the Pos function into searching the whole string for a null
 *    byte then place the string length in s[0].
 *)

procedure MakeString (var s: string);
begin
    s[0] := #255;
    s[0] := Chr(Pos(#0, s) - 1)        { gives -1 (255) if not found }
end;


(*    Here is an assembly language implementation of the C strncpy.
 *    It differs from the standard by not padding unused destination bytes.
 *    Note that when all bytes are used, the string does not get null-
 *    terminated.
 *
 *    The XASSEMBLER keyword means that no LINK and UNLK instructions are
 *    generated although this does mean that we have to use stack offsets
 *    rather than names for accessing the parameters.
 *)

function strncpy (dest, source: pointer; n: integer): STRPTR; xassembler;
asm
    move.w    4(sp),d0            { D0 = max }
    movem.l    6(sp),a0-a1            { A0 = source, A1 = dest }
    move.l    a1,14(sp)            { return dest for convenience }
    bra        @2                    { so we don't do one too many }
@1:
    move.b    (a0)+,(a1)+            { copy characters }
@2:    dbeq    d0,@1                { until reached null or maximum }
end;


(*    This function produces an ASL file requester.  Note that the supplied
 *    dir and name string buffers must be 255 characters long.
 *
 *    Like many Release 2 libraries, ASL uses 'tags'.  These are arrays
 *    tTagItem records (see Utility.pas), each containing an identifying
 *    tag value and some associated data.  TAG_END terminates the list.
 *    C can pass taglists in function calls but Pascal has to use an array
 *    although you can use pairs of long integers rather than tTagItems.
 *)

function ASLRequest (win: pWindow; title, dir, name: STRPTR): boolean;
var fr: ASL.pFileRequester; arg: array [0..8] of long; junk: STRPTR;
begin
    ASLRequest := false;
    arg[0] := ASL_Window;    arg[1] := long(win);
    arg[2] := ASL_Hail;        arg[3] := long(title);
    arg[4] := ASL_Dir;        arg[5] := long(dir);
    arg[6] := ASL_File;        arg[7] := long(name);
    arg[8] := TAG_END;

    fr := AllocASLRequest(ASL_FileRequest, @arg);
    if fr <> NIL then
    begin
        ASLRequest := RequestFile(fr);
        with fr^ do begin
            junk := strncpy(name, rf_File, 255);
            junk := strncpy(dir, rf_Dir, 255)
        end;
        FreeASLRequest(fr)
    end
end;


(*    The ARP version is simple by comparison!
 *)

function ARPRequest (win: pWindow; title, dir, name: STRPTR): boolean;
var fr: ARP.tFileRequester;
begin
    FillChar(fr, sizeof(fr), 0);
    with fr do
    begin
        fr_Window    := win;
        fr_Hail        := title;
        fr_Dir        := dir;
        fr_File        := name
    end;
    ARPRequest := ARP.FileRequest(@fr) <> NIL
end;


(*    Although HighSpeed Pascal does not support procedures as parameters,
 *    a little bit of assembly code magic does the job nicely.  This dummy
 *    function takes the same parameters as the functions we are calling
 *    followed by the function to call.  This is popped off the stack and
 *    jumped to, leaving the correct parameters for our function.
 *)

function CallRequest (win: pWindow;
        title, dir, name: STRPTR; func: pointer): boolean; inline
    $205F,        { move.l (sp)+,a0    }
    $4E90;        { jsr (a0)            }


(*    The main file requester function.  It first looks for the ASL library
 *    and if this is not found, the ARP library.  This means that programs
 *    using it will work under 2.0 and 1.3.  Adding support for other file
 *    requesters is made simple by the use of a function pointer.
 *)

function FRequest(win: pWindow;
        title: string; var selection: string): boolean;
var dir, name: string; lib: pLibrary; func: Pointer;
begin
    FRequest := false;
    lib := OpenLibrary('asl.library', ASL_REV);
    if lib <> NIL then
    begin
        ASLBase    := lib;
        func    := @ASLRequest
    end
    else
    begin
        lib        := OpenLibrary('arp.library', ARP_REV);
        ArpBase    := pArpBase(lib);
        func    := @ARPRequest
    end;

    if lib <> NIL then
    begin
        SplitName(selection, dir, name);
        if CallRequest(win, NullTerm(title),
                NullTerm(dir), NullTerm(name), func) then
        begin
            MakeString(dir);
            MakeString(name);
            AddName(dir, name);
            selection    := dir;
            FRequest    := true
        end;
        CloseLibrary(lib)
    end
end;


(* And just to prove that it really works, here's a sample program! *)
var name: string;
begin
    name := '';
    if FRequest(NIL, 'HighSpeed Pascal Requester', name) then
        WriteLn(name, ' selected')
    else
        WriteLn('Cancelled');
    Delay(100)
end.