Script Library: 1238 scripts
  • Home
  • Script library
  • AltME Archive
  • Mailing list
  • Articles Index
  • Site search
 

Archive version of: file-requester.r ... version: 13 ... luce80 30-Jun-2013

Amendment note: little fixes || Publicly available? Yes

REBOL [
	Title: "Open a file or directory requester"
	Date: 30-06-2013
	Version: 1.4.1
	File: %file-requester.r
	Author: "Marco Antoniazzi"
	Rights: "Copyright (C) 2012-2013 Marco Antoniazzi"
	Purpose: "Requests a file or directory"
	eMail: [luce80 AT libero DOT it]
	History: [
		0.0.1 [02-09-2012 "First version"]
		1.0.0 [08-09-2012 "Finished"]
		1.0.1 [09-09-2012 "Minor fixes"]
		1.0.2 [21-09-2012 "Sort drop down path tree, update scroller on resize"]
		1.0.3 [27-10-2012 "Fixed what-dir for keep, returned full path"]
		1.0.4 [03-11-2012 "Minor fixes, return rebol file!"]
		1.0.5 [09-06-2013 "Fix external loading of tooltip style"]
		1.0.6 [12-06-2013 "Fixed All filter on Linux, hide hidden files on Linux,made styles local"]
		1.0.7 [15-06-2013 "Added some key shortcuts, wheel-scroll on drop-list"]
		1.2.1 [16-06-2013 "Added multi-selection and sorting (now has same functionality as original)"]
		1.2.2 [17-06-2013 "Fixed silly bug of convert string to block of files, default All filter on Linux"]
		1.3.1 [18-06-2013 "Added file renaming (press F2)"]
		1.3.2 [21-06-2013 "Fixed list size on Linux"]
		1.3.3 [23-06-2013 "Fixed keep"]
		1.3.4 [25-06-2013 "Added selection on key, fixed multi selection"]
		1.4.1 [30-06-2013 "Added showing of sizes and dates, various fixes"]
	]
	Note: { Filters can be in the form: "*.a" or "*.a;*.b" or "Short description (*.a)" or "Short description (*.a;*.b)" or
		a block of such strings.
		Use arrows to move in list of files.
		Use F2 to rename currently selected file
	}
	Category: [util vid files]
	library: [
		level: 'intermediate
		platform: 'all
		type: 'function
		domain: [gui files]
		tested-under: [View 2.7.8.3.1 2.7.8.4.3]
		support: none
		license: 'LGPL2
		see-also: none
	]
	thumbnail: http://i40.tinypic.com/nvse8h.png
	comment: "2-Sep-2012 GUI automatically generated by VID_build. Author: Marco Antoniazzi"
	todo: {
		- add possibility to not show hidden files (done for Linux)
		- allow searching
		- display preview
	}
]

file-req: context [
	; files, filter, new folder, rename, drop-list
		suffix?: func [
			{Return the suffix (ext) of a filename or url, else tail of it.} 
			path [any-string!]
			/local
			suff
			][
		    either all [
		        suff: find/last path #"." 
		        not find suff #"/"
		    ] [suff] [tail path]
		]

		dir?: func [file [file!]] [#"/" = last file]

		is-link?: func [file [file!] /local str] [ ; WARNING: THIS IS A DIRTY HACK!
			if all [
				equal? suffix? file %.lnk
				System/version/4 = 3 ;Win
				attempt [str: read file]
				equal? head str find str #{4C000000} 
			] [str]
		]
		
		parent-dir: func [file [file!]] [
			if equal? length? file 1 [return %/]
			file: head remove back tail dirize file
			head remove/part find/tail/last file %/ tail file
		]
		
		online?: does [not error? try [close open tcp://www.google.com:80]]
		
		on-win?: does [system/version/4 = 3]

		gather-each: func ['word [word!] data [series!] body [block!] /into result [block!]] [;collect
			result: any [result copy []]
			forskip data 1 [set word first data if do body [insert tail result first data]]
			head result
		]

		sort_files: func [files [block!]] [
			sort/compare files func [a b] select [
				"Name" [a < b]
				"Size" [(any [size? a 0]) < any [size? b 0]] 
				"Date" [(any [modified? a 1-1-0]) < any [modified? b 1-1-0]]
			] get-face choice-sort
			if "decreasing" = get-face choice-order [files: reverse files]
			files
		]

		filter_and_sort: func [list [block!] /local temp-list filters par temp-dir-list temp-files-list] [
			temp-dir-list: copy list
			if not get-face check-hidden [remove-each item temp-dir-list [found? find/any/match to-string item ".*"]]
			remove-each item temp-dir-list [not dir? item]
			sort_files temp-dir-list
			dirs-count: length? temp-dir-list
			if only-dirs [return temp-dir-list]

			; apply filters
			filters: copy get-face choice-filter
			if par: find filters "(" [filters: next par]
			if par: find filters ")" [clear par]
			filters: parse filters ";"
			temp-list: copy []
			filtering-list: copy list
			forall filters [
				gather-each/into item filtering-list [found? find/any/match item first filters] temp-list
			]

			temp-files-list: copy temp-list
			if not get-face check-hidden [remove-each item temp-files-list [found? find/any/match to-string item ".*"]]
			remove-each item temp-files-list [dir? item]
			sort_files temp-files-list

			clear temp-list
			insert temp-files-list temp-dir-list
			temp-files-list
		]
		
		add_folder: func [/local name][
			name: request-text/title/default/offset "Enter the new folder name below" "New folder" btn-+/offset - 240x-46
			unless none? name [attempt [make-dir path-name/:name replace_file-list path-name]]
		]
		
		rename_file: func [/local scroller-pos old-name name] [
			if (length? list-of-files/picked) = 1 [
				scroller-pos: get-face list-of-files/sld
				old-name: first list-of-files/picked
				name: request-text/title/default/offset "Enter the new file name below" form old-name btn-rename/offset - 160x-46
				unless none? name [
					attempt [
						rename old-name to-rebol-file name
						replace_file-list path-name
						set-face/no-show list-of-files/sld scroller-pos
						do-face list-of-files/sld none
					]
				]
				focus list-of-files ; to unfocus fields
			]
		]

		build_path-tree: func [/local path-tree paths n] [
			path-tree: copy []
			insert path-tree read %/
			remove-each item path-tree [error? try [read/part join %/ item 1]]
			forall path-tree [change path-tree to-local-file first path-tree]
			sort path-tree

			paths: parse/all path-name "/"
			paths: next next paths
			n: 0
			forall paths [insert/dup first paths " " n: n + 2]
			if (length? head paths) >= 2 [
				insert next find path-tree second head paths paths
			]

			head path-tree
		]
		show_drop-list: func [face [object!]] [
			paths-list/data: build_path-tree
			show paths-list/update
			show-popup/window/away paths-lay face/parent-face
			do-events
		]
		select_folder: func [dir [string!] /local path] [
			path: find/tail copy path-name dirize trim dir
			dir: either path [dirize head clear path][to-file rejoin ["/" dir "/"]]
			if replace_file-list dir [add_to_undo-list]
			hide-popup
		]
	; update, enquote, select_line, undo

		update_list: func [/local file file-info] [
			file-list: filter_and_sort orig-file-list
			forall file-list [
				file: first file-list
				file: path-name/:file
				either file-info: info? file [
					change/only file-list reduce [file-list/1 set-size file-info/size file-info/date]
				][
					change/only file-list reduce [file-list/1 "" ""]
				]
			]
			file-list: head file-list

			clear list-of-files/data
			clear list-of-files/picked
			; update and redraw file names text-list
			append list-of-files/data file-list
			set-face list-of-files/sld 0
			show list-of-files/update
		]

		replace_file-list: func [dir-name [file! none!] /init /local temp-dir-list current] [
			if error? try [temp-dir-list: read dir-name] [request/ok/type/offset "Can not read directory, please verify that the name is correct" 'alert req-win/offset + 100x100 return false]
			current: what-dir
			change-dir dir-name
			focus list-of-files ; to unfocus fields
			old-path-name: path-name
			unless any [init saving path-name = dir-name] [clear-face field-selected]
			path-name: dir-name
			clear orig-file-list
			orig-file-list: copy temp-dir-list
			update_list
			set-face info-path to-local-file dir-name
			fn1/state: none
			if init [
				temp-dir-list: unique head insert copy [] names
				forall temp-dir-list [alter list-of-files/picked to-file first temp-dir-list]
				show list-of-files/update
			]
			change-dir current
			
			true
		]
		
		enclose: func [s [series!] vals][head insert tail insert copy s first vals last vals]
		enquote: func [s [series!]][enclose s {"}]    ;-- "

		set-size: func [value [integer!] /local num um bbb div index] [
			um: [" KB" " KB" " MB" " GB"]
			bbb: [1024 1024 1048576 1073741824]
			num: value
			if num = 0 [num: 1]
			div: pick bbb index: to-integer (log-2 num) / 10 + 1 
			value: value / div
			value: case [value = 0.0 [0] value < 0.1 [0.1] 'else [round/to value 0.1]]
			rejoin ["" value pick um index]
		]
		find-data: func [data [block!] value /local item] [
			forall data [item: first data if find item value [return data]] 
		]
		select_line: func [/key dir [word!] /local path str old-index new-index files] [
			if empty? list-of-files/data [return false]
			focus list-of-files
			if empty? path: list-of-files/picked [
				if find [up down home end] dir [
					; try to select 1st file
					append clear list-of-files/picked pick list-of-files/data 1
					show list-of-files/update
					if not dir? first list-of-files/picked [set-face field-selected list-of-files/picked]
					return true
				]
				return false
			]
			path: first path
			either none? dir [
				case [
					dir? path [
						if replace_file-list path-name/:path [add_to_undo-list]
					]
					str: is-link? path-name/:path [ ; WARNING: THIS IS A DIRTY HACK!
						str: back find/any/last str "?:" ; find a: b: c: etc. drive letters
						str: trim/with/all mold copy/part str find str #{00000000} "{^^@}" ; trim 0s
						if replace_file-list dirize to-rebol-file str [add_to_undo-list]
					]
					'else [
						files: unique list-of-files/picked
						if (length? files) > 1 [forall files [change files enquote first files]]
						set-face field-selected files
						return false
					]
				]
			][
				dir: switch/default dir [
						up [-1]
						down [1]
						;page-up [negate visible-lines]
						;page-down [visible-lines]
						home [-10000] ; a great number
						end [10000] ; a great number
					] [return false]
				new-index: dir + old-index: index? find-data list-of-files/data first list-of-files/picked
				new-index: min max 1 new-index length? list-of-files/data
				if new-index = old-index [return false]
				fn1/user-data: new-index ; set "key-cursor"
				
				append clear list-of-files/picked first pick list-of-files/data new-index
				show list-of-files/update
				either dir? first list-of-files/picked [clear-face field-selected][set-face field-selected list-of-files/picked/1]
				true
			]
		]
		select_line-key: func [key /local list line] [
			list: list-of-files/data
			if all [(length? list-of-files/picked) = 1 find/match first list-of-files/picked to-file key] [list: next find-data list-of-files/data list-of-files/picked]
			forall list [
				if line: find/match first first list to-file key [
					line: head line
					append clear list-of-files/picked line
					show list-of-files/update
					if not dir? first list-of-files/picked [set-face field-selected list-of-files/picked]
					break
				]
			]
		]
		add_to_undo-list: does [
			insert undo-list old-path-name
		]
		undo: does [
			if empty? undo-list [exit]
			insert redo-list path-name
			path-name: take undo-list
			replace_file-list path-name
		]
		redo: does [
			if empty? redo-list [exit]
			insert undo-list path-name
			path-name: take redo-list
			replace_file-list path-name
		]
	; gui
		load-script-thru: func ["Load a script from www.rebol.org thru the cache"
			name [file!]
			/flash "Flash a message to the user"
			/local cache-name modul
			][
			cache-name: rejoin [view-root/public/www.rebol.org "/" name]
			modul: any [
				attempt [read cache-name] ; try the cache
				attempt [read name] ; try current dir
				attempt [ ; try downloading it from www.rebol.org
					modul: rejoin [http://www.rebol.org/download-a-script.r?script-name= name]
					read either flash [request-download/to modul cache-name cache-name][modul]
				]
			]
			if modul [clear back back tail modul: load modul] ; remove example code
			modul
		]
		if not value? 'Add-tooltip-2-faces [; tooltip style already loaded?
			attempt [do load-script-thru/flash %simple-tooltip-style.r]
		]
		
		fcnt: 0
		files: none
		fn1: fn2: fn3: fn4: none
		file-req-styles: stylize [
			choice: choice white - 20  font [style: none size: 11 colors: [0.0.0 255.150.55] shadow: none] edge [size: 1x1]
			file-list: panel [
				across
				list [
					across space 0x0
					fn1: txt 280x16	feel [
						redraw: func [face action i] [
							picked: face/parent-face/parent-face/parent-face/picked
							face/color: either find picked face/text [yello][240.240.240]
						]
						over: func [face over? event] [
							if all [many over? integer? face/state][
								clear picked
								if empty? list-of-files/data [exit]
								for n face/state min fcnt length? list-of-files/data either fcnt > face/state [1][-1][
									if not dir? first pick list-of-files/data n [append picked first pick list-of-files/data n]
								]
								show list-of-files
							]
						]
						engage: func [face action event] [
							if fcnt > length? list-of-files/data [exit]
							if event/double-click [
								hide-popup
								face/state: none
								exit
							]
							switch action [
								down [
									either all [many event/shift] [
										if not event/control [clear picked]
										for n face/user-data min fcnt length? list-of-files/data either fcnt > face/user-data [1][-1][
											if not dir? first pick list-of-files/data n [append picked first pick list-of-files/data n]
										]
									][
										if any [not many dir? to-file face/text not event/control] [face/state: fcnt clear picked]
										alter picked face/text
									]
									select_line ; update field-select and reshow
								]
								over [if integer? face/state [append clear picked face/text ]]
								up [
									face/state: none
									if not event/shift [face/user-data: fcnt]
									select_line ; update field-select and reshow
								]
							]
						]
					]

					fn2: txt 60x16 right feel none
					fn3: txt 80x16 right feel none
					fn4: txt 55x16 right feel none
				] supply [
					fcnt: count: count + list-of-files/top
					files: file-list
					face/font/color: black
					face/font/style: []
					face/text: ""
					if count > length? files [return none]
					if all [index = 1 dir? files/:count/1] [face/font/color: blue face/font/style: 'bold]
					face/text: do pick [
						[files/:count/1]
						[either dir? files/:count/1 [""] [files/:count/2]]
						[all [date? files/:count/3 files/:count/3/date]]
						[all [date? files/:count/3 files/:count/3/time]]
					] index
				]
				pad -8x0
				scroller with [list: none] [
					list: face/parent-face
					if face/user-data = value: max 0 to-integer value * ((length? list-of-files/data) - (list-of-files/size/y / fn1/size/y) + 1) [exit]
						face/user-data: list-of-files/top: value
						show list
				]
			] with [
				data: copy []
				picked: copy []
				top: 0
				sld: none
				update: func [/local tot-rows visible-rows item] [
					tot-rows: length? data visible-rows: to-integer (size/y / fn1/size/y)
					sld/redrag visible-rows / max 1 tot-rows
					either visible-rows >= tot-rows [
						sld/step: 0.0
					][
						sld/step: 1 / (tot-rows - visible-rows)
						if item: find-data data picked/1 [
							sld/data: (index? item) / tot-rows ; simple but it works
							if sld/data < sld/step [sld/data: 0]
							top: to-integer sld/data / sld/step
						]
					]
					do-face list-of-files/sld sld/data
					self
				]
				resize: func [new /x /y /local siz][
					siz: new - size
					either any [x y] [
						if x [size/x: new]
						if y [size/y: new]
					][
						size: any [new size]
					]

					foreach [face pair] reduce [
						fn2 1x0
						fn3 1x0
						fn4 1x0
						pane/2 1x0
					][face/offset: face/offset + (siz * pair)]
					foreach [face pair] reduce [
						pane/1 1x1
						pane/1/subface 1x0
						fn1 1x0
					][face/size: face/size + (siz * pair)]
					foreach [face pair] reduce [
						pane/2 0x1
					][face/resize face/size + (siz * pair)]
				]
				append init [
					sld: pane/2
					sld/parent-face: pane
					pane/1/size: size - (pane/2/size * 1x0)
					pane/1/subface/size/x: size/x
					pane/2/offset: pane/1/offset + (pane/1/size * 1x0)
					pane/2/resize/y size/y
				]
			]
		]
		req-win: [
			do [sp: 4x4] origin sp space sp 
			styles file-req-styles
			Across 
			style text text black feel none
			style btn btn 24x24 
			btn "<" [undo] help "Back to previous folder"
			btn ">" [redo] help "Forward"
			btn "^^"  [
				if not none? path-name [
					replace_file-list parent-dir path-name
					add_to_undo-list
				]
			] help "Go up one folder"
			style field field white white edge [color: gray + 30 effect: 'ibevel size: 1x1] 
			info-path: field 365 [if replace_file-list dirize to-rebol-file face/text [add_to_undo-list]]
			pad (sp * -1x0)
			arrow-d: arrow down white 24x24 [show_drop-list face] help "Select a parent directory"
			btn-+: btn "+" 252.223.44 [add_folder] help "Create a new folder"
			return 
			text "Sort by"
			choice-sort: choice "Name" "Size" "Date" 100x20 [replace_file-list path-name]
			text "in"
			choice-order: choice "increasing" "decreasing" 100x20 [replace_file-list path-name]
			text "order"
			pad 80
			btn-rename: btn "Rename" 100x20 252.223.44 [rename_file] help "Rename selected file or folder"
			return
			list-of-files: file-list 500x200
			return
			field-selected: field 336
			pad 0x2 
			text-filter: text "Filter:" 
			pad 0x-2 
			choice-filter: choice "All files (*.*)" "Rebol files (*.r)" 120  [replace_file-list path-name]
			return 
			pad 0x10 
			check-hidden: check-line "Show hidden files" no [replace_file-list path-name]
			pad 172x0 
			btn-ok: btn "Select" 100x24 #"^M" [cancelled: false hide-popup]
			btn-cancel: btn "Cancel" 100 #"^(esc)" [set-face field-selected "" cancelled: true hide-popup]
			key keycode [left] (- sp) [undo]
			key keycode [right] (- sp) [redo]
			key keycode [f2] (- sp) [rename_file]
			do [btn-rename/offset/x: btn-cancel/offset/x]
		]
		; make styles local
		info-path: arrow-d: btn-+: choice-sort: choice-order: btn-rename: list-of-files:
		field-selected: text-filter: choice-filter: check-hidden: btn-ok: btn-cancel: none
		req-win: layout req-win
		if on-win? [remove find req-win/pane check-hidden]
		remove find req-win/pane list-of-files
		insert tail req-win/pane list-of-files ; put on top (to hide lower styles)
		req-win/user-data: reduce ['size req-win/size]
		req-win/options: [resize min-size 500x306]
		if value? 'Add-tooltip-2-faces [Add-tooltip-2-faces req-win]
		field-selected/feel: ctx-text/edit ; restore this

		paths-lay: layout/offset [
			origin 0x0 at 0x0
			paths-list: text-list (info-path/size * 1x0 + arrow-d/size * 1x0 + 0x200) [select_folder value]
		] info-path/offset + (info-path/size * 0x1)
		; patch to avoid closing pop-up with scroll-wheel
		system/view/popface-feel-win-away: make system/view/popface-feel-win [
			process-outside-event: func [event] [
				unless find [move time active inactive scroll-line] event/type [hide-popup]
				event
			]
		]
	
		resize-faces: func [siz [pair!]] [
			foreach [face pair] reduce [
				arrow-d 1x0
				btn-+ 1x0
				btn-rename 1x0
				field-selected 0x1
				text-filter 1x1
				choice-filter 1x1
				check-hidden 0x1
				btn-ok 1x1
				btn-cancel 1x1
			][face/offset: face/offset + (siz * pair)]
			foreach [face pair] reduce [
				info-path 1x0
				field-selected 1x0
				paths-lay 1x0
			][face/size: face/size + (siz * pair)]
			foreach [face pair] reduce [
				list-of-files 1x1
				paths-list 1x0
			][face/resize face/size + (siz * pair)]

			list-of-files/update
		]
		req-win/feel: make req-win/feel [
			detect: func [face event /local siz][
				if any [event/face = req-win event/face = paths-lay] [
				switch event/type [
					close [set-face field-selected "" cancelled: true  hide-popup return none]
					scroll-line [
						either found? find req-win/pane paths-lay [
							either event/offset/y >= 0 [scroll-drag/page paths-list/sld] [scroll-drag/page/back paths-list/sld]
						][
							either event/offset/y >= 0 [scroll-drag list-of-files/sld] [scroll-drag/back list-of-files/sld]
						]
					]
					resize [ 
						siz: face/size - face/user-data/size     ; compute size difference
						face/user-data/size: face/size          ; store new size

						resize-faces siz
						show face
					]
					key [
						if all [system/view/focal-face system/view/focal-face/feel = ctx-text/edit] [ ; editing has precedence
							return event
						]
						if word? event/key [if select_line/key event/key [return none]]
						if all [system/view/focal-face = list-of-files event/key = #"^M" dir? any [pick list-of-files/picked 1 %a]] [if select_line [return none]]
						select_line-key event/key
						if face: find-key-face face event/key [
							if get in face 'action [do-face face event/key]
							return none
						]
					]
				]
				]
				event
			]
		]
	; main
		old-path-name:
		path-name: none
		orig-file-list: ; the unsorted file list
		file-list: [] ; the sorted file list
		undo-list: copy []
		redo-list: copy []
		only-dirs: false
		dirs-count: 0
		many: true
		saving: false
		names: none

		set 'request_file func [
			"Requests a file using a popup list of files and directories."
			/title "Change heading on request."
				title-line "Title line of request"
				button-text "Button text for selection"
			/file name "Default file name or block of file names"
			/filter filt "Filter or block of filters"
			/keep "Keep previous settings and results"
			/only "Return only a single file, not a block."
			/path "Return absolute path followed by relative files."
			/save "Request file for saving, otherwise loading."
			/local result dir-path
			][
			req-win/text: any [title-line "Select a File:"]
			many: either only [false][true]
			if all [not many block? name] [name: pick name 1]
			field-selected/text: any [all [name form name] ""]
			names: name
			if filt [
				filt: compose [(filt)]
				either on-win? [if not find form filt "*.*" [insert tail filt "All files (*.*)"]][insert tail filt "All files (*)"]
				choice-filter/text: first choice-filter/data: choice-filter/texts: filt
			]
			btn-ok/text: any [button-text either save ["Save"]["Select"]]
			if only-dirs [list-of-files/resize list-of-files/size - 0x30]
			saving: to logic! save

			only-dirs: false
			replace_file-list/init any [path-name path-name: what-dir]

			show-popup req-win
			do-events
			unfocus

			if none? keep [ ; restore defaults
				choice-filter/text: first choice-filter/data: choice-filter/texts: ["All files (*.*)" "Rebol files (*.r)"]
				choice-sort/text: first choice-sort/data: head choice-sort/data
				choice-order/text: first choice-order/data: head choice-order/data
				path-name: none
			]
			result: get-face field-selected
			if "" = trim result [return none]
			; convert string to block of files
			result: parse result none
			forall result [change result to-rebol-file first result]
			dir-path: dirize to-rebol-file get-face info-path
			if only [return join dir-path result/1]
			either path [
				insert result dir-path
			][
				foreach file result [insert file dir-path]
			]
			head result
		]
		set 'request_dir func [
			"Requests a directory using a popup list."
			/title "Change heading on request." title-line
			/dir "Set starting directory" where [file!]
			/keep "Keep previous directory path"
			/offset xy [pair!]
			/local offs result
			][
			req-win/text: any [title-line "Select a directory:"]
			if offset [offs: req-win/offset req-win/offset: xy]
			btn-ok/text: "Select" ; restore default value
			if not only-dirs [list-of-files/resize list-of-files/size + 0x30]

			only-dirs: true
			replace_file-list any [where path-name path-name: what-dir]

			show-popup req-win
			do-events
			unfocus

			result: path-name
			if none? keep [ ; restore defaults
				req-win/offset: offs
				choice-sort/text: first choice-sort/data: head choice-sort/data
				choice-order/text: first choice-order/data: head choice-order/data
				path-name: none
			]
			if cancelled [return none]
			result
		]
]

do ; just comment this line to avoid executing examples
[
probe request_file/keep/title/filter "gimme file" "Load" ["*.r; *.c" "files (*.s ; *.t)"]
probe request_dir/title/offset "gimme dir" 100x100
probe request_dir/title/offset "gimme dir" 100x100
probe request_file/path/title "gimme file again" "Get it"
halt
]