home *** CD-ROM | disk | FTP | other *** search
/ The Best of Mecomp Multimedia 1 / Mecomp-CD.iso / amiga / grafic / visagecom / visagecom.e next >
Encoding:
Text File  |  1997-06-29  |  31.9 KB  |  1,097 lines
  1. /*************************************************************************
  2. *                                                                        *
  3. *                              VisageCom                                 *
  4. *                                                                        *
  5. *  By Philippe "Elwood" FERRUCCI                         Decines FRANCE  *
  6. *                                                                        *
  7. *************************************************************************/
  8.  
  9. MODULE 'dos/dos',     -> SIGBREAKF_CTRL_D,SHARED_LOCK
  10.        'intuition/screens','intuition/intuition',
  11.        'gadtools','libraries/gadtools','reqtools','libraries/reqtools',
  12.        'utility/tagitem','graphics/gfxbase',
  13.        'graphics/gfx',       -> rectangle
  14.        'graphics/rastport',  -> rastport
  15.        'graphics/view',      -> viewport
  16.        'graphics/text','exec/ports','exec/nodes',
  17.        'graphics/modeid',    -> MONITOR_ID_MASK
  18.        'graphics/displayinfo',
  19.        'dos/dosextens','exec/tasks',
  20.  
  21.        'intuition/intuitionbase',       
  22.  
  23.        'exec/io',            -> iostdreq
  24.        'devices/input',      -> CMD_WAITEVENT
  25.        'devices/inputevent', -> inputevent
  26.        'exec/memory'         -> MEMF_PUBLIC
  27.  
  28. ENUM NONE,NOARGS,NOMEM,NOLIB,NOGAD,NOFILE1,NOFILE2,NOSCREEN,NOMODE
  29.  
  30. CONST LACE=2
  31.  
  32. DEF progname[50]:STRING,args:PTR TO LONG,template,rdargs,modeid=NIL
  33.  
  34. -> filename can be 108 chars long
  35. DEF filename[108]:STRING,destination[78]:STRING,
  36.     pathname[78]:STRING,basename[30]:STRING,validdest
  37.  
  38. DEF p_filelock=NIL,fib=NIL:PTR TO fileinfoblock       -> init with NIL
  39.  
  40. DEF scr=NIL:PTR TO screen,win=NIL:PTR TO window,wintitle[100]:STRING,topscreen
  41. DEF p_ta=NIL:PTR TO textattr,p_tf:PTR TO textfont   -> default font
  42.  
  43. DEF visual,glist=NIL,p_gad:PTR TO gadget
  44. DEF idcmp
  45.  
  46. DEF getout=0,useranswer,visagetask:PTR TO task   -> to store the visage task
  47.  
  48. DEF tmpstr[108]:STRING
  49.  
  50. OBJECT button      -> used to create a list of button
  51.   item:PTR TO CHAR
  52. ENDOBJECT
  53.  
  54. RAISE NOARGS  IF ReadArgs() = NIL,            -> automatic error handling :
  55.       NOLIB   IF OpenLibrary() = NIL,         -> when the program is done
  56.       NOMEM   IF OpenScreenTagList() = NIL,   -> I sequentially pick each
  57.       NOGAD   IF GetVisualInfoA() = NIL,      -> potential failure of the
  58.       NOGAD   IF CreateContext() = NIL,       -> program and I build this
  59.       NOGAD   IF CreateGadgetA() = NIL,       -> list.
  60.       NOMEM   IF OpenWindowTagList() = NIL,   -> Thanks to Wouter, the
  61.       NOFILE1 IF Read() = -1,                 -> source is easier to read
  62.       NOMEM   IF New() = NIL,                 -> and understand.
  63.       NOFILE2 IF AddPart() = NIL,
  64.       NOMEM   IF RtAllocRequestA() = NIL
  65.  
  66. PROC main() HANDLE
  67.   VOID '$VER: VisageCom 1.5 By Philippe "Elwood" FERRUCCI (01/07/97)'
  68.  
  69.   init()
  70.  
  71.   opengui()
  72.  
  73.   mainloop()
  74.  
  75.   Raise(NONE)    -> everything is done we get out of here.
  76.  
  77. EXCEPT
  78.   IF fib THEN FreeDosObject(DOS_FIB,fib)
  79.  
  80.   IF scr THEN ScreenToBack(scr)
  81.   IF win THEN CloseWindow(win); win := NIL  -> close the window first !
  82.   IF glist THEN FreeGadgets(glist)          -> and this line second.
  83.   IF visual THEN FreeVisualInfo(visual)
  84.   IF gadtoolsbase THEN CloseLibrary(gadtoolsbase)
  85.   IF reqtoolsbase THEN CloseLibrary(reqtoolsbase)
  86.  
  87.   IF scr    THEN CloseScreen(scr);    scr    := NIL
  88.  
  89.   -> I close everything before saying Visage to continue to avoid problems
  90.   -> I encoutered in double buffering mode
  91.   -> (the new selected window wasn't the "in front" one)
  92.  
  93.   -> when Visage is showing an image it (Visage itself or the datatype it
  94.   -> is using) locks that file, so before deleting I have to say to Visage
  95.   -> to continue in order to remove the lock on the file
  96.  
  97.   IF (getout = -1) OR (getout = 1) THEN
  98.      IF visagetask THEN Signal(visagetask,SIGBREAKF_CTRL_D)
  99.  
  100.   IF getout = 1
  101.      Delay(50)             -> I wait a while to be sure lock is dead
  102.      DeleteFile(filename)  -> guess what this dos library function do ?
  103.   ENDIF
  104.  
  105.   SELECT exception
  106.     CASE NOARGS
  107.       StrCopy(wintitle,'Usage: ',ALL)
  108.       StrAdd(wintitle,progname,ALL)
  109.       StrAdd(wintitle,' <filename> [destination] [MODEID]',ALL)
  110.       dowarn(wintitle)
  111.     CASE NOMEM
  112.       dowarn('Not enough memory !')
  113.     CASE NOLIB
  114.       dowarn('Can''t open required libraries !')
  115.     CASE NOGAD
  116.       dowarn('Failure in a gadtools function !')
  117.     CASE NOFILE1
  118.       dowarn('Can''t read file correctly !')
  119.     CASE NOFILE2
  120.       dowarn('Can''t write file !')
  121.     CASE NOSCREEN
  122.       dowarn('Can''t find Visage screen !')
  123.     CASE NOMODE
  124.       dowarn('Incorrect modeid !')
  125.   ENDSELECT
  126.   CleanUp(0)    -> Amiga E cleans used RAM
  127.  
  128. ENDPROC
  129.  
  130. PROC init()
  131.  
  132.   -> this is only for writing a good 'Usage' message (if you changed the
  133.   -> name of the prog (in 'Vcom' for instance)
  134.   IF (GetProgramName(progname,50)) = 1 THEN StrCopy(progname,'VisageCom',ALL)
  135.  
  136.   args:=[NIL,NIL,NIL,NIL]                          -> init args structure.
  137.   template:='FILE/A,DEST,MODEID/K,TOPSCREEN/K/N'     -> 1 argument needed.
  138.   rdargs:=ReadArgs(template,args,NIL)      -> dos library function.
  139.  
  140.   StrCopy(filename,args[],ALL)             -> copy of args in Estring
  141.   IF args[1]
  142.      StrCopy(destination,args[1],ALL)
  143.   ELSE
  144.      StrCopy(destination,'nothing/:',ALL)
  145.   ENDIF
  146.   IF args[2] THEN modeid := Val(args[2])
  147.   IF args[3]
  148.      topscreen := args[3]
  149.      topscreen := Long(topscreen)
  150.   ENDIF
  151.   FreeArgs(rdargs)                             -> dos library function.
  152.  
  153.   IF modeid THEN IF ModeNotAvailable(modeid) <> NIL THEN Raise(NOMODE)
  154.  
  155.   getfilefib(filename)
  156.   extractfilenames(filename,pathname,basename)
  157.  
  158.   checkdest()  -> check if destination is valid and copy is possible
  159.  
  160.   gadtoolsbase := OpenLibrary('gadtools.library',39)  -> open needed libs
  161.   reqtoolsbase := OpenLibrary('reqtools.library',38)
  162.  
  163.   getdefaultfont()
  164.  
  165. ENDPROC
  166.  
  167. PROC getfilefib(name:PTR TO CHAR)
  168. DEF tmp
  169.  
  170.   IF (p_filelock := Lock(name,SHARED_LOCK)) = NIL THEN Raise(NOFILE1)
  171.  
  172.   -> we fill the FIB structure with file informations
  173.   IF fib = NIL THEN IF (fib := AllocDosObject(DOS_FIB,NIL)) = NIL THEN Raise(NOFILE1)
  174.  
  175.   tmp := Examine(p_filelock,fib) 
  176.   IF tmp = 0                           -> fills 'fib' structure
  177.      FreeDosObject(DOS_FIB,fib)        -> with infos about the file
  178.      fib := NIL
  179.   ENDIF
  180.   UnLock(p_filelock)
  181.  
  182. ENDPROC
  183.  
  184. PROC extractfilenames(file:PTR TO CHAR,path:PTR TO CHAR,name:PTR TO CHAR)
  185. DEF tmpptr:PTR TO CHAR,tmplock,pos
  186.  
  187.   IF tmplock := Lock(file,SHARED_LOCK)
  188.  
  189.      -> we get the complete filename (even if not specified)
  190.      NameFromLock(tmplock,file,108)
  191.  
  192.      tmpptr := FilePart(file)           -> extract only the file name
  193.      StrCopy(name,tmpptr,ALL)
  194.  
  195.      -> we get the path name
  196.      tmpptr := PathPart(file) - file
  197.      MidStr(path,file,0,tmpptr)
  198.  
  199.      UnLock(tmplock)
  200.  
  201.   ELSE   -> file doesn't exist
  202.  
  203.      pos := FilePart(file)
  204.      IF pos = file                            -> only the file
  205.         GetCurrentDirName(path,78)
  206.         StrCopy(name,file,ALL)
  207.      ELSE
  208.         MidStr(path,file,0,pos-file)
  209.         MidStr(name,file,pos-file,ALL)
  210.         IF tmplock := Lock(path,SHARED_LOCK)  -> from ram: to Ram Disk:
  211.            NameFromLock(tmplock,path,78)
  212.            UnLock(tmplock)
  213.         ENDIF
  214.      ENDIF
  215.   ENDIF
  216.  
  217. ENDPROC
  218.  
  219. PROC checkdest()
  220. DEF tmplock
  221.  
  222.   -> we check if destination is valid
  223.   IF tmplock := Lock(destination,SHARED_LOCK)
  224.      UnLock(tmplock)
  225.      validdest := TRUE
  226.   ELSE
  227.      validdest := FALSE
  228.      StrCopy(destination,'<Invalid>',ALL)
  229.   ENDIF
  230.  
  231. ENDPROC
  232.  
  233. PROC validname()
  234. DEF tmplock,tmpname,strlen,valid
  235.  
  236.   -> we check if a filename with this name exists in destination
  237.  
  238.   strlen := EstrLen(destination)+EstrLen(basename)+1   -> extra 1 char for /:
  239.  
  240.   tmpname := String(strlen)
  241.   StrCopy(tmpname,destination,ALL)
  242.   AddPart(tmpname,basename,108)
  243.  
  244.   IF tmplock := Lock(tmpname,SHARED_LOCK)
  245.      UnLock(tmplock)
  246.      valid := FALSE
  247.   ELSE
  248.      valid := TRUE
  249.   ENDIF
  250.  
  251.   DisposeLink(tmpname)
  252.  
  253. ENDPROC valid
  254.  
  255. PROC getdefaultfont()
  256. DEF gfx:PTR TO gfxbase,node:PTR TO node
  257.  
  258.   -> we look for the default font
  259.   gfx := gfxbase           -> we get a pointer to the gfxbase structure
  260.   p_tf := gfx.defaultfont  -> in gfxbase we get a pointer to a textfont struct
  261.   node := p_tf.message.node   -> and another pointer to get the fontname
  262.   p_ta := [node.name,p_tf.ysize,p_tf.style,p_tf.flags]:textattr
  263.  
  264. ENDPROC
  265.  
  266. PROC getintuilen(str:PTR TO CHAR)
  267. DEF len,intui:PTR TO intuitext
  268.  
  269.   len := 0
  270.   IF p_ta
  271.      intui := [1,0,RP_JAM1,0,0,p_ta,str,NIL]:intuitext
  272.      len := IntuiTextLength(intui)
  273.   ENDIF
  274.  
  275. ENDPROC len
  276.  
  277. PROC opengui()
  278. DEF displayid,p_vp:PTR TO viewport,p_disinfo:displayinfo,p_diminfo:dimensioninfo
  279. DEF p_drawinfo:PTR TO drawinfo, -> to get the Wb pen array
  280.     pens=NIL:PTR TO INT         -> to store the pen array
  281. DEF wbscr:PTR TO screen,islace,y
  282.  
  283.   -> we get the Visage screen to see which monitor it use
  284.   scr := findscreen('Visage')
  285.   IF scr = NIL THEN Raise(NOSCREEN)
  286.   p_vp := scr.viewport
  287.  
  288.   -> if the modeid is not specified as argument we get the visage screen one
  289.   IF modeid
  290.      displayid := modeid
  291.   ELSE
  292.      displayid := GetVPModeID(p_vp)
  293.      IF displayid = INVALID_ID THEN displayid := 0
  294.      displayid := BestModeIDA([BIDTAG_VIEWPORT,p_vp,
  295.                                BIDTAG_NOMINALWIDTH,640,
  296.                                TAG_END])
  297.      displayid := displayid OR $8000  -> at least HIRES
  298.   ENDIF
  299.  
  300.   -> get infos about the desired screen (if not found, set default)
  301.   islace := 0
  302.   IF topscreen = FALSE
  303.      IF GetDisplayInfoData(NIL,p_disinfo,SIZEOF displayinfo,DTAG_DISP,displayid)
  304.         islace := p_disinfo.propertyflags AND DIPF_IS_LACE
  305.         IF GetDisplayInfoData(NIL,p_diminfo,SIZEOF dimensioninfo,DTAG_DIMS,displayid)
  306.            y := p_diminfo.nominal.maxy
  307.         ELSE
  308.            islace := FALSE
  309.            y := 256
  310.         ENDIF
  311.      ELSE
  312.         islace := FALSE
  313.         y := 256
  314.      ENDIF
  315.      IF islace   -> 1: INTERLACE
  316.         topscreen := y - miniwinsize(2,1,LACE)
  317.      ELSE
  318.         topscreen := y - miniwinsize(2,1)
  319.      ENDIF
  320.   ENDIF
  321.  
  322.   wbscr := LockPubScreen('Workbench')
  323.   IF wbscr
  324.     p_drawinfo := GetScreenDrawInfo(wbscr)
  325.     pens := NewR(p_drawinfo.numpens)
  326.     pens := p_drawinfo.pens
  327.     FreeScreenDrawInfo(wbscr,p_drawinfo)
  328.     UnlockPubScreen(NIL,wbscr)
  329.   ELSE
  330.     pens:=[0,1,1,2,1,3,1,0,2,1,2,1]:INT
  331.   ENDIF
  332.  
  333.   scr := OpenScreenTagList(NIL,[SA_DISPLAYID,displayid,  -> same monitor
  334.                                 SA_DEPTH,4,              -> # of bitplanes
  335.                                 SA_PENS,pens,
  336.  
  337.                                 SA_TOP,topscreen,        -> open here
  338.  
  339.                                 SA_TYPE,PUBLICSCREEN,
  340.                                 SA_PUBNAME,'VisageCom',
  341.                                 SA_DRAGGABLE,FALSE,
  342.                                 SA_AUTOSCROLL,FALSE,
  343.                                 SA_BEHIND,TRUE,
  344.                                 SA_QUIET,TRUE,
  345.                                 TAG_DONE])            -> end of tag list
  346.  
  347.   visual := GetVisualInfoA(scr,NIL) -> initialises some gadtools structures
  348.  
  349.   p_gad := CreateContext({glist})   -> creates the shadow gadget used as
  350.                                     -> the first gadget of the window
  351.  
  352.   -> the same thing is done 6 times (each gadget) so it would be too long
  353.   -> and unreadable here. That's why I used a PROC routine.
  354.   p_gad:=preparegadget(p_gad,['_Copy','_Delete','_Move','_Rename',
  355.                               'C_omment','_Set Dir','C_ancel']:button)
  356.  
  357.   win := OpenWindowTagList(NIL,[WA_PUBSCREEN,scr,  -> screen to open on
  358.                                 WA_CLOSEGADGET,TRUE,
  359.                                 WA_GADGETS,glist,  -> gadget list prepared
  360.                                 WA_ACTIVATE,    TRUE,
  361.   -> I want to be warned by the great Amiga IDCMP system when those
  362.   -> events occured: key/mousebutton pressed or window is inactivated or
  363.   -> a gadget has been used...
  364.                                 WA_IDCMP, IDCMP_VANILLAKEY OR
  365. ->                                          IDCMP_MOUSEBUTTONS OR
  366.                                           IDCMP_CLOSEWINDOW OR
  367. ->                                          IDCMP_INACTIVEWINDOW OR
  368. ->                                          IDCMP_INTUITICKS OR
  369.                                           IDCMP_GADGETUP,
  370.                                 WA_TITLE, wintitle,
  371.                                 TAG_DONE])
  372.  
  373.   Gt_RefreshWindow(win,NIL)   -> needed by gadtools after window is opened
  374.  
  375.   IF validdest = FALSE THEN disablegad(win,[1,3])
  376.  
  377.   setwindow() -> sets the window title and writes the comment
  378.  
  379.   ScreenToFront(scr)          -> the screen is ready to be introduced to you
  380.  
  381.   p_gad := getgadget(win,7)
  382.   setmouse(scr,p_gad.leftedge,p_gad.topedge) -> mouse goes to last gadget
  383.  
  384. ENDPROC
  385.  
  386. PROC setwindow()
  387. DEF oldrast,p_gad:PTR TO gadget
  388.  
  389.   StrCopy(wintitle,'Image: ',ALL)
  390.   StrAdd(wintitle,basename,ALL)
  391.   StrAdd(wintitle,'   Dest.: ',ALL)
  392.   StrAdd(wintitle,destination,ALL)
  393.   SetWindowTitles(win,wintitle,-1)  -> updates the window title
  394.  
  395.   IF fib
  396.  
  397.      oldrast := SetStdRast(win.rport)
  398.      SetAPen(win.rport,1)
  399.  
  400.      -> Write the comment (if set)
  401.      IF StrLen(fib.comment)
  402.         StrCopy(tmpstr,fib.comment,ALL)
  403.      ELSE
  404.         StrCopy(tmpstr,'<No comment set>',ALL)
  405.      ENDIF
  406.  
  407.      p_gad := getgadget(win,1)      -> get gadget 1 (where we'll write text)
  408.  
  409.      -> if comment is shorter than previous, it must erase the previous
  410.      fillstring(tmpstr,80)
  411.      stripstr(tmpstr,p_gad.leftedge)
  412.      TextF(p_gad.leftedge,getrow(1,[0,0,1]),'\s',tmpstr)
  413.  
  414.      StringF(tmpstr,'\d',fib.size)
  415.      numformat(tmpstr)
  416.      StrAdd(tmpstr,' bytes.',ALL)
  417.      TextF(p_gad.leftedge,getrow(2,[0,0,1]),'\s',tmpstr)
  418.  
  419.      SetStdRast(oldrast)
  420.   ENDIF
  421.  
  422. ENDPROC
  423.  
  424. PROC mainloop()
  425. DEF int:PTR TO intuitionbase,screen:PTR TO screen
  426.  
  427.   -> !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  428.   -> Please pay attention that if you use gadtools features you have to
  429.   -> use gadtools version of message managing: GT_GetIMsg and GT_ReplyIMsg
  430.   -> instead of the intuition equivalent (GetMsg and ReplyMsg) included in
  431.   -> in the E procedure WaitIMessage (have a look at this one in the E doc)
  432.   -> used here (I know I'm a bad boy ! )
  433.  
  434.   WHILE getout = 0
  435.  
  436.     idcmp := WaitIMessage(win)        -> we wait one of the wanted IDCMP
  437.  
  438.     SELECT idcmp
  439.  
  440.       CASE IDCMP_CLOSEWINDOW
  441.          getout := -2
  442.  
  443.       CASE IDCMP_INTUITICKS
  444.          -> 10 times a second, I'll receive this IDCMP
  445.          int := intuitionbase
  446.          screen := int.firstscreen.nextscreen  -> must be the Visage screen
  447.          IF StrCmp(screen.title,'Visage') = FALSE THEN getout := -2
  448.  
  449.       CASE IDCMP_GADGETUP             -> a gadget has been pressed/released
  450.          p_gad := MsgIaddr()          -> which one ?
  451.          getout := p_gad.gadgetid     -> 'getout' is set with the gadget id
  452.  
  453.       CASE IDCMP_MOUSEBUTTONS         -> button pressed
  454.          -> left mouse button pressed outside the window
  455.          IF (MsgCode() = SELECTUP) AND (scr.mousey < 0) THEN getout := -2
  456.  
  457.       CASE IDCMP_INACTIVEWINDOW
  458.          ActivateWindow(win)   -> makes the window be the active one again
  459.  
  460.       CASE IDCMP_VANILLAKEY       -> a key pressed
  461.          useranswer := MsgCode()  -> which one ?
  462.          SELECT useranswer
  463.            CASE "c"               -> Copy
  464.              getout:=1
  465.            CASE "d"               -> Delete
  466.              getout:=2
  467.            CASE "m"               -> Move
  468.              getout:=3
  469.            CASE "r"               -> Rename
  470.              getout:=4
  471.            CASE "o"               -> Comment
  472.              getout:=5
  473.            CASE "s"               -> Set dir
  474.              getout:=6
  475.            CASE "a"               -> Cancel
  476.              getout:=-2
  477.            CASE "q"               -> Cancel
  478.              getout:=-2
  479.            CASE "0"               -> Cancel
  480.              getout:=-2
  481.            CASE 27                -> ESC
  482.              getout:=-2
  483.            CASE 32                -> SPACE => Cancel and continue
  484.              getout:=-1
  485.          ENDSELECT
  486.  
  487.     ENDSELECT
  488.  
  489.     -> Action !!!
  490.     SELECT getout
  491.  
  492.     -> all delete actions are made later, see below for explanation
  493.  
  494.       CASE 1          -> copy
  495.          docopy()
  496.          getout := 0
  497.       CASE 2          -> delete
  498.          getout := 1
  499.       CASE 3
  500.          IF domove()     -> move done with no error
  501.             getout := 1
  502.          ELSE
  503.             getout := 0
  504.          ENDIF
  505.       CASE 4
  506.          dorename()     -> rename
  507.          setwindow()
  508.          getout := 0
  509.       CASE 5
  510.          docomment()
  511.          getfilefib(filename)
  512.          setwindow()
  513.          getout := 0
  514.       CASE 6
  515.          setdir()      -> we change destination
  516.          setwindow()
  517.          getout := 0   -> we continue
  518.     ENDSELECT
  519.  
  520.   ENDWHILE
  521.  
  522. ENDPROC
  523.  
  524. PROC preparegadget(gad:PTR TO gadget,buttonlist:PTR TO button)
  525. DEF saveptr,id,len,text[100]:STRING
  526. DEF intuilen,leftedge,topedge,underscorelen,totalsize=0
  527. DEF posarray:PTR TO LONG,sizearray:PTR TO LONG
  528.  
  529.   -> fasten your seat belt and here we go
  530.   -> I hope this is the good way to do it
  531.  
  532.   len := ListLen(buttonlist)   -> how much gadget we have to create
  533.  
  534.   saveptr := buttonlist
  535.  
  536.   -> I use the RtSpread function which says where each gadget must be placed
  537.  
  538.   underscorelen := getintuilen('_')
  539.  
  540.   -> RtSpread gives the position of each gadget
  541.   sizearray := [0,0,0,0,0,0,0]:LONG
  542.  
  543.   FOR id := 0 TO len-1           -> BAD:   FOR ind := 1 TO ListLen(buttonlist)
  544.     StrCopy(text,^buttonlist,ALL)
  545.     buttonlist++                 -> we get the next one
  546.     intuilen := getintuilen(text) - underscorelen + 10
  547.     PutLong(4*id + sizearray,intuilen)      -> puts intuilen in sizearray
  548.     totalsize := totalsize + intuilen
  549.   ENDFOR
  550.  
  551.   posarray := [0,0,0,0,0,0,0]:LONG
  552.   RtSpread(posarray,sizearray,totalsize,20,scr.width-30,7)
  553.   -> extra pixels at beginning          ^  and end   ^            
  554.  
  555.   topedge := getrow(3,[0,0,1]) -> line for gadgets
  556.  
  557.   buttonlist := saveptr
  558.   FOR id := 1 TO len           -> BAD:   FOR ind := 1 TO ListLen(buttonlist)
  559.     StrCopy(text,^buttonlist,ALL)   -> we get the text of the current object
  560.     buttonlist++                    -> we get the next one for next run
  561.  
  562.     leftedge := ^posarray
  563.     posarray++
  564.  
  565.     -> length of current gadget text
  566.     intuilen := getintuilen(text)
  567.  
  568.     IF ((id = 1) OR (id = 3)) AND (validdest = FALSE)  -> Copy/Move disabled
  569.        gad := CreateGadgetA(
  570.                BUTTON_KIND,gad,              -> type,previous gadget
  571.                [leftedge,topedge,
  572.                  intuilen+10,(p_tf.ysize*2), -> leftedge,topedge,width,height
  573.                  text,p_ta,                  -> gadgettext,font
  574.                  id,PLACETEXT_IN,            -> ID,position
  575.                  visual,0]:newgadget,        -> visual,userdata
  576.                [GT_UNDERSCORE,"_",
  577.                 GFLG_DISABLED,TRUE,TAG_END])   -> additional taglist
  578.     ELSE
  579.        gad := CreateGadgetA(
  580.                BUTTON_KIND,gad,              -> type,previous gadget
  581.                [leftedge,topedge,
  582.                  intuilen+10,(p_tf.ysize*2), -> leftedge,topedge,width,height
  583.                  text,p_ta,                  -> gadgettext,font
  584.                  id,PLACETEXT_IN,            -> ID,position
  585.                  visual,0]:newgadget,        -> visual,userdata
  586.                [GT_UNDERSCORE,"_",TAG_END])  -> additional taglist
  587.     ENDIF
  588.   ENDFOR
  589.  
  590. ENDPROC gad
  591.  
  592. -> enables gadgets of a specific window
  593. PROC enablegad(p_win:PTR TO window,idlist:PTR TO LONG)
  594. DEF len,i,gadid,p_gad:PTR TO gadget
  595.  
  596.   -> instead of saving the gadget address of the 2 gadgets I wanted to
  597.   -> enable/disable, I wrote this PROC which allows you to enable the
  598.   -> first and the third gadget of a specific window calling:
  599.   -> enablegad(win,[1,3])
  600.  
  601.   len := ListLen(idlist)
  602.   p_gad := p_win.firstgadget   -> we get the address of the first gadget
  603.  
  604.   FOR i := 1 TO len            -> for each number of gadget, we look for it
  605.     gadid := ^idlist; idlist++          -> in the gadget list
  606.     WHILE p_gad.gadgetid <> gadid       -> of the window
  607.       p_gad := p_gad.nextgadget         -> and we enable the one
  608.     ENDWHILE                            -> we want: the first one and the
  609.     OnGadget(p_gad,p_win,NIL)           -> third one here.
  610.   ENDFOR
  611.  
  612. ENDPROC
  613.  
  614. PROC disablegad(p_win:PTR TO window,idlist:PTR TO LONG)
  615. DEF len,i,gadid,p_gad:PTR TO gadget
  616.  
  617.   len := ListLen(idlist)
  618.   p_gad := p_win.firstgadget
  619.  
  620.   FOR i := 1 TO len
  621.     gadid := ^idlist; idlist++
  622.     WHILE p_gad.gadgetid <> gadid
  623.       p_gad := p_gad.nextgadget
  624.     ENDWHILE
  625.     OffGadget(p_gad,p_win,NIL)
  626.   ENDFOR
  627.  
  628. ENDPROC
  629.  
  630. -> look for a specified gadget (id) in a window
  631. PROC getgadget(p_win:PTR TO window,id)
  632. DEF p_gad:PTR TO gadget
  633.  
  634.   p_gad := p_win.firstgadget
  635.  
  636.   WHILE p_gad <> NIL
  637.     IF p_gad.gadgetid = id
  638.        RETURN p_gad
  639.     ELSE
  640.       p_gad := p_gad.nextgadget
  641.     ENDIF
  642.   ENDWHILE
  643.  
  644. ENDPROC p_gad
  645.  
  646. PROC docopy()
  647.  
  648.   IF validname() = FALSE
  649.      DisplayBeep(scr)
  650.      IF getnewname(destination,basename) = FALSE THEN RETURN FALSE
  651.   ELSE
  652.      StrCopy(tmpstr,destination,ALL)
  653.      AddPart(tmpstr,basename,108)
  654.   ENDIF
  655.  
  656. ENDPROC copyfile(filename,tmpstr)
  657.  
  658. PROC domove()
  659.  
  660.   IF validname() = FALSE
  661.      DisplayBeep(scr)
  662.      IF getnewname(destination,basename) = FALSE THEN RETURN FALSE
  663.   ELSE
  664.      StrCopy(tmpstr,destination,ALL)
  665.      AddPart(tmpstr,basename,108)
  666.   ENDIF
  667.  
  668. ENDPROC movefile(filename,tmpstr)
  669.  
  670. PROC getdiskinfos(dir:PTR TO CHAR)
  671. DEF tmplock,p_info:PTR TO infodata,freespace,diskstate
  672.  
  673.   freespace := 0; diskstate := 0
  674.   IF (tmplock := Lock(dir,SHARED_LOCK))
  675.      p_info := NewR(SIZEOF infodata)
  676.      IF Info(tmplock,p_info)
  677.         diskstate := p_info.diskstate
  678.         freespace := p_info.numblocks-p_info.numblocksused*p_info.bytesperblock
  679.      ENDIF
  680.      Dispose(p_info)
  681.      UnLock(tmplock)
  682.   ENDIF
  683.  
  684. ENDPROC diskstate,freespace
  685.  
  686. PROC writeabledisk(dest:PTR TO CHAR)
  687. DEF destdir[78]:STRING,destfile[30]:STRING,diskstate,freespace
  688.  
  689.   extractfilenames(dest,destdir,destfile)
  690.  
  691.   diskstate,freespace := getdiskinfos(destdir)
  692.   IF diskstate = ID_WRITE_PROTECTED THEN Raise(1)
  693.   IF StrCmp(destdir,'Ram Disk:',ALL) THEN freespace := AvailMem(MEMF_TOTAL)
  694.  
  695. ENDPROC freespace
  696.  
  697. PROC copyfile(src:PTR TO CHAR,dest:PTR TO CHAR) HANDLE
  698. DEF filelen,filehandler=NIL,mem=NIL,freespace
  699.  
  700.   freespace := writeabledisk(dest)
  701.  
  702.   IF (filehandler := Open(src,OLDFILE)) = NIL THEN Raise(NOFILE1)
  703.  
  704.   filelen := FileLength(src)
  705.   IF freespace < filelen THEN Raise(2)
  706.  
  707.   mem := NewR(filelen)             -> we allocate memory to store the file
  708.   Read(filehandler,mem,filelen)    -> we store the file in memory
  709.   Close(filehandler)               -> close the file
  710.  
  711.   IF (filehandler := Open(dest,NEWFILE)) = NIL THEN Raise(NOFILE2)
  712.   IF Write(filehandler,mem,filelen) = -1  -> error (e.g. no free space)
  713.      Close(filehandler)
  714.      DeleteFile(dest)
  715.      Raise(3)
  716.   ELSE
  717.      Close(filehandler)
  718.      -> copy date and filecomment found in 'fib'
  719.      IF fib
  720.         SetFileDate(dest,fib.datestamp)
  721.         SetComment(dest,fib.comment)
  722.         SetProtection(dest,fib.protection)
  723.      ENDIF
  724.   ENDIF
  725.  
  726.   RETURN TRUE
  727.  
  728. EXCEPT
  729.   IF filehandler THEN Close(filehandler)
  730.   SELECT exception
  731.     CASE 1
  732.       dowarn('Disk is write protected')
  733.     CASE 2
  734.       dowarn('Not enough space on disk')
  735.     CASE 3
  736.       dowarn('An error has occured (disk full ?)')
  737.   ENDSELECT
  738.  
  739.   RETURN FALSE
  740.  
  741. ENDPROC
  742.  
  743. PROC movefile(src:PTR TO CHAR,dst:PTR TO CHAR)
  744. DEF path1[78]:STRING,path2[78]:STRING,name[30]:STRING
  745.  
  746.   extractfilenames(src,path1,name)
  747.   extractfilenames(dst,path2,name)
  748.   IF samedevice(path1,path2)
  749.      IF Rename(src,dst) = FALSE
  750.         DeleteFile(dst)      -> if newname already exists
  751.         Rename(src,dst)
  752.      ENDIF
  753.   ELSE
  754.      IF copyfile(src,dst) = NIL THEN RETURN FALSE
  755.      -> delete of 'filename' is done exiting Visage
  756.   ENDIF
  757.  
  758.   RETURN TRUE
  759.  
  760. ENDPROC
  761.  
  762. PROC dorename()
  763. DEF wintitle[130]:STRING,path[78]:STRING,name[30]:STRING
  764.  
  765.   StrCopy(wintitle,'Enter new name for ',ALL)
  766.   StrAdd(wintitle,basename,ALL)
  767.  
  768.   -> if user closed the requester with return/OK then rename file
  769.   IF getnewname(pathname,basename) = 1
  770.  
  771.      -> extracts the path and name
  772.      extractfilenames(tmpstr,path,name)
  773.      IF samedevice(path,pathname)
  774.         IF Rename(filename,tmpstr) = FALSE
  775.            DeleteFile(tmpstr)      -> if newname already exists
  776.            Rename(filename,tmpstr)
  777.         ENDIF
  778.      ELSE
  779.         IF copyfile(filename,tmpstr) = NIL THEN RETURN FALSE
  780.         DeleteFile(filename)
  781.      ENDIF
  782.      StrCopy(filename,tmpstr,ALL)
  783.      extractfilenames(filename,pathname,basename)
  784.     
  785.   ENDIF
  786.  
  787.   RETURN TRUE
  788.  
  789. ENDPROC
  790.  
  791. PROC samedevice(path1:PTR TO CHAR,path2:PTR TO CHAR)
  792. DEF same=FALSE,lock1,lock2
  793.  
  794.   IF (lock1 := Lock(path1,SHARED_LOCK)) = NIL THEN RETURN FALSE
  795.   IF (lock2 := Lock(path2,SHARED_LOCK)) = NIL THEN RETURN FALSE
  796.  
  797.   same := SameDevice(lock1,lock2)
  798.  
  799.   UnLock(lock1)
  800.   UnLock(lock2)
  801.  
  802. ENDPROC same
  803.  
  804. -> opens a file requester to ask the user a filename
  805. -> useranswer: TRUE if user OKs the requester else FALSE
  806. -> tmpstr: set to full filename if TRUE
  807. PROC getnewname(path:PTR TO CHAR,file:PTR TO CHAR)
  808. DEF req:PTR TO rtfilerequester,answer[108]:ARRAY
  809.  
  810.   req := RtAllocRequestA(RT_FILEREQ,NIL)
  811.  
  812.   ScreenPosition(scr,SPOS_ABSOLUTE OR SPOS_FORCEDRAG,0,0,0,0)
  813.  
  814.   IF path THEN RtChangeReqAttrA(req,[RTFI_DIR,path,TAG_DONE])
  815.  
  816.   StrCopy(answer,file,ALL)
  817.   useranswer := RtFileRequestA(req,
  818.                                answer,'Choose a new name',
  819.                                [RT_SCREEN,scr,  -> screen,
  820.                                 RT_REQPOS,REQPOS_CENTERSCR,
  821.                                 RTFI_FLAGS,FREQF_SAVE,
  822.                                 TAG_DONE])
  823.   IF useranswer
  824.      StrCopy(tmpstr,req.dir,ALL)  -> if we change directory too
  825.      AddPart(tmpstr,answer,108)
  826.   ENDIF
  827.  
  828.   RtFreeRequest(req)
  829.  
  830.   ScreenPosition(scr,SPOS_ABSOLUTE OR SPOS_FORCEDRAG,0,topscreen,0,0)
  831.  
  832. ENDPROC useranswer
  833.  
  834. PROC docomment()
  835. DEF oldcomment[108]:STRING,wintitle[130]:STRING
  836.  
  837.   StrCopy(wintitle,'Enter comment for ',ALL)
  838.   StrAdd(wintitle,basename,ALL)
  839.  
  840.   IF fib THEN StrCopy(oldcomment,fib.comment,ALL)
  841.  
  842.   -> if user closed the requester with return/OK then save comment
  843.   StrCopy(tmpstr,oldcomment,ALL)
  844.   IF askstring(wintitle,TRUE)
  845.      SetComment(filename,tmpstr)
  846.      getfilefib(filename)
  847.   ENDIF
  848.  
  849. ENDPROC     -> used to know if setcomment has been done
  850.  
  851. PROC setdir()
  852. DEF req:PTR TO rtfilerequester,answer[108]:ARRAY
  853.  
  854.   req := RtAllocRequestA(RT_FILEREQ,NIL)
  855.  
  856.   ScreenPosition(scr,SPOS_ABSOLUTE OR SPOS_FORCEDRAG,0,0,0,0)
  857.  
  858.   IF validdest THEN RtChangeReqAttrA(req,[RTFI_DIR,destination,TAG_DONE])
  859.   useranswer := RtFileRequestA(req,
  860.                                answer,'Choose a new destination',
  861.                                [RT_SCREEN,scr,
  862.                                 RT_REQPOS,REQPOS_CENTERSCR,
  863.                                 RTFI_FLAGS,FREQF_NOFILES,
  864.                                 TAG_DONE])
  865.   IF useranswer
  866.      validdest := TRUE
  867.      StrCopy(destination,req.dir,ALL)
  868.      enablegad(win,[1,3])
  869.   ENDIF
  870.  
  871.   RtFreeRequest(req)
  872.  
  873.   ScreenPosition(scr,SPOS_ABSOLUTE OR SPOS_FORCEDRAG,0,topscreen,0,0)
  874.  
  875. ENDPROC
  876.  
  877. PROC setmouse(scr:PTR TO screen,x,y)
  878. -> based upon SetMouse from Ketil Hunn
  879.  
  880. DEF p_iostdreq:PTR TO iostdreq,mp:PTR TO msgport,p_ievent:PTR TO inputevent
  881. DEF ppix:PTR TO iepointerpixel
  882.  
  883.   IF (mp := CreateMsgPort())
  884.      IF (p_ievent := AllocVec(SIZEOF inputevent, MEMF_PUBLIC))
  885.         IF (ppix := AllocVec(SIZEOF iepointerpixel, MEMF_PUBLIC))
  886.            IF p_iostdreq := CreateIORequest(mp,SIZEOF iostdreq)
  887.               IF Not (OpenDevice('input.device', NIL, p_iostdreq, NIL))
  888.                  ppix.screen    := scr
  889.                  ppix.positionx := x
  890.                  ppix.positiony := y
  891.  
  892.                  p_ievent.nextevent    := NIL
  893.                  p_ievent.class        := IECLASS_NEWPOINTERPOS
  894.                  p_ievent.subclass     := IESUBCLASS_PIXEL
  895.                  p_ievent.code         := 0
  896.                  p_ievent.qualifier    := NIL
  897.                  p_ievent.eventaddress := ppix
  898.  
  899.                  p_iostdreq.data    := p_ievent
  900.                  p_iostdreq.length  := SIZEOF inputevent
  901.                  p_iostdreq.command := IND_WRITEEVENT
  902.                  DoIO(p_iostdreq)
  903.  
  904.                  CloseDevice(p_iostdreq)
  905.               ENDIF
  906.               DeleteIORequest(p_iostdreq)
  907.            ENDIF
  908.            FreeVec(ppix)
  909.         ENDIF
  910.         FreeVec(p_ievent)
  911.      ENDIF
  912.      DeleteMsgPort(mp)
  913.   ENDIF
  914.  
  915. ENDPROC
  916.  
  917. PROC findscreen(name:PTR TO CHAR)
  918. DEF screen:PTR TO screen,int=NIL:PTR TO intuitionbase,found=FALSE
  919. DEF p_mp:PTR TO msgport
  920.  
  921.   int := intuitionbase
  922.   screen := int.firstscreen
  923.  
  924.   WHILE (found = FALSE) AND (screen <> NIL)
  925.     IF StrCmp(screen.title,name,ALL)
  926.        found := TRUE
  927.     ELSE
  928.        screen := screen.nextscreen
  929.     ENDIF
  930.   ENDWHILE
  931.  
  932.   IF found = FALSE
  933.      screen := NIL
  934.      visagetask := NIL
  935.   ELSE
  936.      -> task associated with the window on the visage screen used to
  937.      -> signal Visage to continue
  938.      p_mp := screen.firstwindow.userport
  939.      visagetask := p_mp.sigtask
  940.   ENDIF
  941.  
  942. ENDPROC screen
  943.  
  944. PROC dowarn(message:PTR TO CHAR)
  945. DEF req,answer
  946.  
  947.   IF reqtoolsbase
  948.      req := RtAllocRequestA(RT_REQINFO,NIL)
  949.      answer := RtEZRequestA(message,
  950.                             'Ok',
  951.                             NIL,
  952.                             req,
  953.                             [RT_WINDOW,win,
  954.                              RT_IDCMPFLAGS,IDCMP_INACTIVEWINDOW,
  955.                              TAG_DONE])
  956.      RtFreeRequest(req)
  957.   ELSE
  958.      EasyRequestArgs(NIL,   -> window
  959.                 [SIZEOF easystruct,0,'Error...',message,'OK'],
  960.                 [IDCMP_INACTIVEWINDOW OR
  961.                  IDCMP_RAWKEY],NIL)
  962.   ENDIF
  963.  
  964. ENDPROC
  965.  
  966. -> ask a string to the user via a reqtools requester.
  967. -> tmpstr: string used in input/output
  968. PROC askstring(wintitle:PTR TO CHAR,allowempty=FALSE)
  969. DEF req,answer
  970.  
  971.   req := RtAllocRequestA(RT_REQINFO,NIL)     -> allocate what is needed (!)
  972.   answer := RtGetStringA(tmpstr,79,wintitle,req,
  973.                          [RT_WINDOW,win,
  974.                           RT_IDCMPFLAGS,IDCMP_INACTIVEWINDOW,
  975.                           RTGS_WIDTH,win.width,
  976.                           RTGS_ALLOWEMPTY,allowempty,
  977.                           RT_TOPOFFSET,0,
  978.                           TAG_DONE])     -> taglists should end like this
  979.   RtFreeRequest(req)                         -> free what was allocated
  980.  
  981.   -> if window is unactivated requester is canceled
  982.   IF answer = IDCMP_INACTIVEWINDOW THEN answer := 0
  983.  
  984. ENDPROC answer
  985.  
  986. -> fills a string with spaces until len is reached
  987. PROC fillstring(str:PTR TO CHAR,len)
  988. DEF ind
  989.  
  990.   ind := StrLen(str)
  991.  
  992.   WHILE ind <= len 
  993.      str[ind] := " "
  994.      INC ind
  995.   ENDWHILE
  996.   str[ind] := "\0"
  997.  
  998. ENDPROC
  999.  
  1000. -> says the minimum height of a window according to the default font
  1001. PROC miniwinsize(txtlines,gadlines,islace=1)
  1002. ENDPROC 11+2+ (((p_tf.ysize+5*txtlines)+(p_tf.ysize+5*gadlines)) * islace)
  1003. -> bordertop, borderbottom,,,at bottom
  1004.  
  1005. -> returns the X position to be used to display a text/gadget
  1006. PROC getrow(row,rowlst:PTR TO LONG)
  1007. DEF rowlen,ind,rowtype,y
  1008.  
  1009.   DEC row
  1010.   ind := 0
  1011.   y := scr.wbortop + p_tf.ysize + 1
  1012.   rowlen := ListLen(rowlst) - 1
  1013.  
  1014.   WHILE ind < row
  1015.     rowtype := rowlst[ind]
  1016.     IF rowtype = 0  -> text
  1017.        y := y + p_tf.ysize + 3
  1018.     ELSE            -> gadget
  1019.        y := y + p_tf.ysize + 10
  1020.     ENDIF
  1021.     INC ind
  1022.   ENDWHILE
  1023.   rowtype := rowlst[ind]
  1024.   IF rowtype = 0  -> text
  1025.      y := y + p_tf.ysize + 3
  1026.   ELSE
  1027.      y := y + 5
  1028.   ENDIF
  1029.  
  1030. ENDPROC y
  1031.  
  1032. -> limite une chaine pour qu'elle entre dans la fenetre
  1033. -> str: chaine à écrire
  1034. -> orig: x d'origine ou sera écrite la chaine
  1035. PROC stripstr(str:PTR TO CHAR,orig)
  1036. DEF len,ok=FALSE,maxx,strlen
  1037.  
  1038.   maxx := win.width - win.borderright
  1039.   strlen := StrLen(str)
  1040.  
  1041.   REPEAT
  1042.  
  1043.     len := getintuilen(str)
  1044.     IF (orig + len) <= maxx
  1045.        ok := TRUE
  1046.     ELSE
  1047.        DEC strlen
  1048.        str[strlen] := "\0"
  1049.     ENDIF
  1050.  
  1051.   UNTIL ok
  1052.  
  1053. ENDPROC
  1054.  
  1055. -> formate une chaine contenant un numérique (MAX=999 999 999)
  1056. -> 12 345 678
  1057. -> 0123456789
  1058. PROC numformat(p_str:PTR TO CHAR)
  1059. DEF str,len,ind,indtmp,indstr,spaces,tmp,mod
  1060.  
  1061.   str := p_str
  1062.   len := StrLen(str)
  1063.  
  1064.   IF (len < 4) OR (len > 9) THEN RETURN  -> jusqu'à un Giga
  1065.  
  1066.   mod := Mod(len,3)
  1067.   IF mod = 0
  1068.      spaces := (len / 3) - 1
  1069.   ELSE
  1070.      spaces := len / 3
  1071.   ENDIF
  1072.  
  1073.   tmp := String(len+spaces)
  1074.   indstr := 0
  1075.   indtmp := 0
  1076.   ind := len - (3 * spaces)  -> position du premier " "
  1077.   len := len + spaces - 1    -> longueur de tmp (condition d'arrêt)
  1078.  
  1079.   WHILE indtmp <= len
  1080.  
  1081.     IF indtmp = ind
  1082.        tmp[indtmp] := " "
  1083.        spaces := 0
  1084.        ind := ind + 4  -> position de l'espace suivant
  1085.     ELSE
  1086.        tmp[indtmp] := str[indstr]
  1087.        INC indstr
  1088.     ENDIF
  1089.     INC indtmp
  1090.  
  1091.   ENDWHILE
  1092.   tmp[indtmp] := "\0"
  1093.   StrCopy(str,tmp,ALL)
  1094.   DisposeLink(tmp)
  1095.  
  1096. ENDPROC
  1097.