| View script | License | Download script | History | Other scripts by: luce80 |
18-Apr 21:35 UTC
[0.056] 22.48k
[0.056] 22.48k
 | Archive version of: file-requester.r ... version: 1 ... luce80 9-Sep-2012Amendment note: new script || Publicly available? Yes REBOL [
Title: "Open a file or directory requester"
Date: 09-09-2012
Version: 1.0.1
File: %file-requester.r
Author: "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"]
]
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
}
Category: [util vid files]
library: [
level: 'intermediate
platform: 'all
type: 'function
domain: [gui files]
tested-under: [View 2.7.8.3.1]
support: none
license: 'LGPL2
see-also: none
]
comment: "2-Sep-2012 GUI automatically generated by VID_build. Author: Marco Antoniazzi"
]
file-req: context [
; files, filter, new folder, 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]]
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
]
filter_and_sort: func [list [block!] /local temp-list filters par temp-dir-list temp-files-list] [
temp-dir-list: copy list
remove-each item temp-dir-list [not dir? item]
sort 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
remove-each item temp-files-list [dir? item]
sort 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]]
]
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]
paths: parse/all path-name "/"
paths: next next paths
n: 0
forall paths [insert/dup first paths " " n: n + 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, undo
update_list: func [] [
file-list: filter_and_sort orig-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
do-face list-of-files/sld none
show list-of-files/update
]
replace_file-list: func [dir-name [file! none!] /local temp-dir-list] [
if error? try [temp-dir-list: read dir-name] [alert "Can not read directory, please verify that the name is correct" return false]
focus list-of-files ; to unfocus fields
old-path-name: path-name
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
true
]
select_line: func [ /local path str] [
if empty? path: get-face list-of-files [exit]
path: last path
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 [
unless empty? list-of-files/picked [set-face field-selected list-of-files/picked]
]
]
]
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
tip*: any [
attempt [load %simple-tooltip-style.r]
attempt [if online? [load http://www.rebol.org/download-a-script.r?script-name=simple-tooltip-style.r]]
]
if tip* [clear back back tail tip*] ; remove example code
do tip*
file-req-styles: stylize [
arrow: arrow feel [
over-super: :over
over: func [face action event][
over-super face action event
remove/part find face/effect 'gradient 4
if action [
insert face/effect [gradient 0x-1 white orange]
]
show face
]
]
choice: choice white - 20 font [style: none size: 11 colors: [0.0.0 255.150.55] shadow: none] edge [size: 1x1]
dir-list: text-list 500x200 with [
update: func [/local tot-rows visible-rows] [
tot-rows: length? data visible-rows: lc
sld/redrag visible-rows / max 1 tot-rows
either visible-rows >= tot-rows [
sld/step: 0.0
][
sld/step: 1 / (tot-rows - visible-rows)
]
self
]
append init [
sld/action: func [face value] [ ;patched
if sn = value: max 0 to-integer value * ((length? slf/data) - lc) [exit] ; I always hated that "1 +" !
sn: value
show sub-area
]
iter/feel: make iter/feel [
redraw-super: :redraw
redraw: func [f a i /local fil] [
redraw-super f a i
fil: to-file iter/text
iter/font/color: case [
dir? fil [blue]
is-link? path-name/:fil [blue]
true [black]
]
iter/font/style: either dir? fil ['bold][[]]
]
engage-super: :engage
engage: func [face action event /local fil] [
engage-super face action event
if event/double-click [
fil: to-file iter/text
either dir? fil [
do-face face none
][
if not empty? get-face field-selected [hide-popup]
]
exit
]
]
]
]
]
]
req-win: layout [
do [sp: 4x4] origin sp space sp
styles file-req-styles
Across
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 389 [if replace_file-list dirize to-rebol-file face/text [add_to_undo-list]]
pad (sp * -1x0 - 23x-1)
arrow-d: arrow down white 22x22 edge none [show_drop-list face] help "Select a parent directory"
pad 0x-1
btn-+: btn "+" 252.223.44 [add_folder] help "Create a new folder"
return
list-of-files: dir-list 500x200 [select_line]
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 296x10
btn-ok: btn "Select" 100x24 [cancelled: false hide-popup]
btn-cancel: btn "Cancel" 100 #"^[" [set-face field-selected "" cancelled: true hide-popup]
]
remove find req-win/pane list-of-files
insert tail req-win/pane list-of-files ; put on top
req-win/user-data: reduce ['size req-win/size]
req-win/options: [resize min-size 500x300]
if tip* [Add-tooltip-2-faces req-win]
paths-lay: layout/offset [
origin 0x0 at 0x0
paths-list: text-list (info-path/size * 1x0 + 0x200) [select_folder value]
] info-path/offset + (info-path/size * 0x1)
rezize-faces: func [siz [pair!]] [
foreach [face pair] reduce [
arrow-d 1x0
btn-+ 1x0
field-selected 0x1
text-filter 1x1
choice-filter 1x1
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)]
]
req-win/feel: make req-win/feel [
detect: func [face event /local siz][
switch event/type [
close [set-face field-selected "" cancelled: true hide-popup return none]
scroll-line [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
rezize-faces siz
show face
]
]
system/view/window-feel/detect face event ; deal with key presses
]
]
; main
old-path-name:
path-name: what-dir
orig-file-list: ; the unsorted file list
file-list: [] ; the sorted file list
undo-list: copy []
redo-list: copy []
only-dirs: false
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." ;not implemented (but is default behaviour)
;/path "Return absolute path followed by relative files." ;not implemented
/save "Request file for saving, otherwise loading."
/local result
][
req-win/text: any [title-line "Select a File:"]
field-selected/text: any [name ""]
if filt [
filt: compose [(filt)]
if not find form filt "*.*" [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]
only-dirs: false
replace_file-list path-name
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)"]
path-name: what-dir
]
result: get-face field-selected
if "" = result [return none]
to-file 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]
if not only-dirs [list-of-files/resize list-of-files/size + 0x30]
only-dirs: true
replace_file-list any [where path-name]
show-popup req-win
do-events
unfocus
if cancelled [return none]
result: path-name
if none? keep [ ; restore defaults
req-win/offset: offs
path-name: what-dir
]
result
]
]
;comment [
do [
probe request_file/title/filter "gimme file" "Load" ["*.r; *.c" "files (*.s ; *.t)"]
probe request_dir/title/offset "gimme dir" 100x100
probe request_file/title "gimme file again" "Load"
halt
] |