Otherware/Otherware_1_SB_Development.iso/mac/hypercar/xfcn/filename.sit/FileName.p

Text File | 1987-10-31 | 7.2 KB | 266 lines

{$R-              }
{$S FileName }

(*** Filename

This HyperCard XFunction will present the user with the standard
SFGetFile dialog box and return the users responce to the caller
as either a full path name of the new file or empty if canceled.

I have departed from the human interface guidelines for dialog
boxes as the SFGetFile dialog will be centered in the hypercard
window and not the screen.  My reson for this is that HyperCard
has only one window (ignoring message box, &c) within which many
of the rules are broken so by placing the dialog centered on the
window it clearly indicates the dialog has been presented do to
pressing a button.

Much of the code is a taken from the FileName XFunction by

    Steve Maller
    Apple Computer Training Support
    Copyright ⌐ 1987 Apple Computer
    AppleLink: MALLER1

To compile and link with MPW and MPW Pascal

    pascal -w FileName.p

    link -m ENTRYPOINT
         -rt XFCN=1
         -sn Main=FileName
         -o HyperCommands
         FileName.p.o
         Interface.o
         Paslib.o

A typical HyperTalk script calling NewFileName would be

    -- function FileName( [ <type> ] ): <filename>

    on mouseUp
        put FileName( "TEXT" ) into filename

        if filename is not empty then
            open file filename
            read from file filename until return
            put it into field x
            close file filename
        end if
    end mouseDown

Written by

    Andrew Gilmartin
    Academic & User Service, Box 1885
    Brown University
    Providence, Rhode Island 02912
    Copyright ⌐ 1987 Brown University
    bitnet:  ANDREW@BROWNVM

    October 31, 1987 ***)


unit filenameUnit;

    interface

        uses memtypes, quickdraw, osintf, toolintf, packintf, hyperxcmd;

        procedure entrypoint(paramptr: xcmdptr);

    implementation

        procedure filename(paramptr: xcmdptr); forward;

        procedure entrypoint(paramptr: xcmdptr);
        begin
            filename(paramptr);
        end(* entry point *);

        procedure filename;

            var fullpathname: str255;
                filename    : str255;
                prompt        : str255;
                reply        : sfreply;
                numtypes    : integer;
                typelist    : sftypelist;

            {$I xcmdglue.inc }


            (**    Param To Num

            This function returns a long integer interpretation of
            a zero terminated string (c-string). **)

            function paramtonum( param: handle ): longInt;
                var Str: Str255;
            begin
                zerotopas( param^, str );
                paramtonum := strtonum( str )
            end(* ParamToNum *);


            (**  CenterRect

            This function will return the point where the top left corner
            of inside rectange should be placed inorder for it to be
            centered within outside rectangle.

            It is not checked that inside is indeed wholely inside of
            outside **)

            function centerrect( outr, inr: rect ): point;
                var p: point;
            begin
                p.v := outr.top  + (((outr.bottom - outr.top) - (inr.bottom  - inr.top)) div 2);
                p.h := outr.left + (((outr.right - outr.left) - (inr.right  - inr.left)) div 2);
                centerrect := p
            end(* center rect *);


            (**    Card Rect

            This function will return a rectangle that specifies where
            the HyperCard window (aka this card) is upon the screen.
            It should be noted that the position is determined by asking
            HyperCard rather than calling toolbox routines. **)

            function cardrect: rect;
                var card: rect;
            begin
                card.top    := ParamToNum( evalexpr( 'item two of loc of card window' ) );
                card.left   := ParamToNum( evalexpr( 'item one of loc of card window' ) );
                card.bottom := card.top  + 342;
                card.right  := card.left + 512;
                cardrect    := card
            end(* card rect *);


            (**    Dialog Rect

            This function returns a rectangle that specifies where the
            SFGetFile dialog whould be placed upon the screen. **)

            function dialogrect: rect;
                var dialog: dialogthndl;
            begin
                dialog       := dialogthndl( getresource( 'DLOG', getdlgid ) );
                dialogrect := dialog^^.boundsrect
            end(* dialog rect *);


            (**    Build Pathname

            This function will return the full pathname from the volume
            reference number and filename.  This code is a taken from
            Steve Maller's original XFunction "FileName". **)

            function buildpathname( volume:integer; filename: str255): Str255;
                var fullpathname: str255;
                    name        : str255;
                    err            : integer;
                    mywdpb        : wdpbptr;
                    mycpb        : cinfopbptr;
                    mypb        : hparmblkptr;
            begin

                buildpathname := '';

                {
                first we allocate some memory in the heap for the
                parameter block. this could in theory work on the stack,
                but in reality it makes no difference as we're entirely
                modal (ugh) here...
                }
                mycpb  := cinfopbptr(newptr(sizeof(hparamblockrec)));
                if ord4(mycpb) <= 0 then
                    exit(buildpathname);            { rats! bill didn't leave enough room }
                mywdpb := wdpbptr(mycpb);            { icky pascal type coercions follow }
                mypb   := hparmblkptr(mycpb);


                name := '';                         { start with an empty name }
                mypb^.ionameptr := @name;            { we want the volume name }
                mypb^.iocompletion := pointer(0);
                mypb^.iovrefnum := volume;            { returned from sfgetfile }
                mypb^.iovolindex := 0;                { use the vrefnum and name }
                err := pbhgetvinfo(mypb, false);    { fill in the volume info }
                if err <> noerr then
                    exit(buildpathname);

                {
                now we need the working directory (wd) information
                because we're going to step backwards from the file
                through all of the the folders until we reach the
                root directory
                }
                mywdpb^.iovrefnum := volume;        { this got set to 0 above }                    mywdpb^.iowdprocid := 0;                            { use the vrefnum }
                mywdpb^.iowdindex := 0;                { we want all directories }
                err := pbgetwdinfo(mywdpb, false);    { do it }
                if err <> noerr then
                    exit(buildpathname);

                mycpb^.iofdirindex := - 1;                { use the iodirid field only }
                mycpb^.iodrdirid := mywdpb^.iowddirid;    { info returned above }
                err := pbgetcatinfo(mycpb, false);        { do it }
                if err <> noerr then
                    exit(buildpathname);

                {
                here starts the real work - start to climb the tree by
                continually    looking in the iodrparid field for the next
                directory above until we fail...
                }
                mycpb^.iodrdirid := mycpb^.iodrparid;    { the first folder}
                fullpathname      := concat(mycpb^.ionameptr^, ':', filename);

                repeat
                    mycpb^.iodrdirid := mycpb^.iodrparid;
                    err := pbgetcatinfo(mycpb, false);    { the next level }

                    {
                    be careful of an error returned here - it means the user
                    chose a file on the desktop level of this volume. if this
                    is the case, just stop here and return "volumename:filename",
                    otherwise loop until failure
                    }

                    if err = noerr then
                        fullpathname := concat(mycpb^.ionameptr^, ':', fullpathname);

                until err <> noerr;

                disposptr(pointer(mycpb));    { clean up your heap! }

                buildpathname := fullpathname

            end(* build path name *);

        begin

            with paramptr^ do
                begin
                    if paramcount <> 1 then { filename() }
                        numtypes := -1
                    else                     { filename( "TEXT" ) }
                        begin
                            numtypes := 1;
                            blockmove( params[ 1 ]^, @typelist[ 0 ], 4 )
                        end;

                    sfgetfile( centerrect( cardrect, dialogrect ),
                               '', nil, numtypes, typelist, nil, reply );

                    if reply.good then
                        fullpathname := buildpathname( reply.vrefnum,
                                                       reply.fname );

                    returnvalue := pastozero(fullpathname)
                end

        end(* filename *);

end.