REBOL [ title: "Archiver" file: %archiver.r author: "Marco Antoniazzi" Rights: "Copyright (C) 2016 Marco Antoniazzi. All Rights Reserved" email: [luce80 AT libero DOT it] date: 20-04-2016 version: 0.8.2 Purpose: "Backup files" help: { INSTRUCTIONS: Fill the fields and press "Do". A new temporary folder with a tree with all the specified folders and files will be created, all the specified folders and files will be copied there and then that folder will be compressed thus preserving all file structures. Finally the temporary folder will be deleted. } comment: "27-Mar-2016 GUI automatically generated by VID_build. Author: Marco Antoniazzi" History: [ 0.0.1 [27-03-2016 "Started"] 0.8.0 [28-03-2016 "Finished"] 0.8.1 [11-04-2016 "Added sorting, improved scroller, improved selecting, added now exit, fixed closing help-win"] 0.8.2 [20-04-2016 "fixed name of simple-vid-resizing.r"] ] library: [ level: 'intermediate platform: ['win 'linux] type: 'tool domain: 'files tested-under: [View 2.7.8.3.1 Atronix-View 3.0.0.3.3] support: none license: 'BSD see-also: none ] thumbnail: http://i68.tinypic.com/2j3nzwp.png ] ;**** please set correct path to vid1r3.r3 and sdk sources (or use empty string to use default path to sdk) **** if all [system/version > 2.9.0 not value? 'mimic-do-event] [do/args %../../r3/local/vid1r3.r3 %../../sdk-2706031/rebol-sdk-276/source] err?: func [blk /local arg1 arg2 arg3 message err][;11-Feb-2007 Guest2 if not error? err: try blk [return :err] err: disarm err set [arg1 arg2 arg3] reduce [err/arg1 err/arg2 err/arg3] message: get err/id if block? message [bind message 'arg1] alert rejoin ["ERROR: " form reduce message ". THE PROGRAM WILL TERMINATE."] none ] either debug: false ;true [ err?: :do ][ prin: print: func [val] [to-error form get/any 'val] svv/error: func [msg spot] [to-error [msg]] ; patch VID error function to keep it silent ] err? [ svv/vid-face/color: white - 30 ; background color of all windows and faces ; modules load-script-thru: func ["Load a script from www.rebol.org thru the cache" name [file!] /flash "Flash a message to the user" /warn "Alert user if script not found" /from path [file!] "Optional path where to search for the script" /local cache-name modul ][ if not value? 'view-root [view-root: either system/version/4 = 3 [%/C/Users/Public/Documents] [%/tmp]] cache-name: view-root/:name modul: any [ attempt [read cache-name] ; try the cache attempt [read name] ; try current dir attempt [read rejoin [undirize path "/" name]] ; try optional 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 if all [not modul warn] [alert rejoin ["Script <" name "> not found."]] modul ] parent-dir: func [file [file!]] [ if equal? length? file 1 [return %/] file: head remove back tail dirize file ; undirize head clear find/tail/last file %/ ] on-linux?: system/version/4 = 4 if not value? 'file-req-ctx [; already loaded? attempt [ do load-script-thru/flash %file-requester.r if on-linux? [request-file: :request_file] request-dir: :request_dir ] ] if not value? 'resizer-ctx [; already loaded? attempt [do load-script-thru/flash %simple-vid-resizing.r] ] ; misc enquote: func [string [string!]] [rejoin [{"} string {"}]] do-dir: func [ "For all files in a directory and subdirectories, recursively call a function or do a block as: func [file] block" [catch] dir [file! url!] action [function! block!] /deep count [integer!] "limit to the given level of depth" /local files ][ count: any [count 1000000] if count < 0 [exit] if block? :action [action: func [file] action] action dir if all [ dir? dir dir: dirize dir attempt [files: load dir] ] [ foreach file files [do-dir/deep dir/:file :action count - 1] ] ] build_tree: func [/local temp src dest files name info] [ make-dir temp: to-rebol-file trim get-face field-temp view/new center-face/with info: center-face layout [text-info: text "" bold 800x50] main-window files: text-list-files/data forall files [ src: to-rebol-file first files dest: parse next src "/" ; remove file part to avoid creating a wrong dir if not dir? src [remove back tail dest] name: copy "" forall dest [ name: rejoin [name %/ first dest] make-dir rejoin [temp %/ next name] ] either dir? src [ ; rebuild same tree structure as src do-dir src [ set-face text-info reform ["Coping: " file] name: rejoin [temp file] either dir? file [ make-dir rejoin [temp file] ][ write/binary/direct name read/binary/direct file ] ] ][ name: rejoin [temp src] set-face text-info reform ["Coping: " name] write/binary/direct name read/binary/direct src ] ] unview/only info temp ] ; file, cfg, undo, exit change_title: func [window /modified] [ clear find/tail window/text "- " if modified [saved?: no append window/text "*"] append window/text to-string last split-path any [job-name %Untitled] window/changes: [text] show window ;set-win-title window/text ] choose_file: func [ext [string!] /local file-name] [ until [ file-name: request-file/keep/only/filter ext if none? file-name [return none] exists? file-name ] to-local-file file-name ] open_file: func [/local file-name cfg ] [ if all [not none? job-name not request/confirm/offset "Replace current configuration?" main-window/offset + 100x100] [exit] until [ file-name: request-file/title/keep/only/filter "Load a configuration file" "Load" "*.ren" if none? file-name [exit] exists? file-name ] if none? cfg: attempt [load file-name] [exit] if (select cfg 'info) <> "Archiver prefs file" [ alert "Wrong configuration file" exit ] load_cfg cfg job-name: file-name named: yes change_title main-window saved?: yes ] save_file: func [/as /local file-name filt ext response cfg] [ attempt [change-dir first split-path job-name] if not named [as: true] if as [ filt: "*.ren" ext: %.ren file-name: request-file/title/keep/only/save/filter "Save a configuration file" "Save" filt if none? file-name [return false] if none? suffix? file-name [append file-name ext] if not-equal? suffix? file-name ext [append file-name ext] response: true if exists? file-name [response: request/offset rejoin [{File "} last split-path file-name {" already exists, overwrite it?}] main-window/offset + 100x100] if response <> true [return false] job-name: file-name named: yes ] ;flash/with join "Saving to: " job-name main-window ;probe cfg: make_cfg append cfg compose [ win-pos (main-window/offset) win-size (main-window/size) ] either not none? attempt [write job-name mold/only cfg] [ ;wait 1.3 change_title main-window saved?: yes ][ alert "Configuration NOT saved" saved?: no ] saved? ] load_cfg: func [cfg [block!] /local files root-face][ replace/all cfg/general 'true true replace/all cfg/general 'false false foreach [style value] [ field-archive archive field-archiver archiver field-command command field-temp temp ] [attempt [set-face get style select cfg/general value]] update_archiver saved?: yes root-face: find-window main-window root-face/offset: cfg/win-pos root-face/size: cfg/win-size show root-face files: attempt [cfg/files] if any [none? files empty? files] [exit] clear text-list-files/data text-list-files/data: files append clear text-list-files/picked first text-list-files/data show text-list-files/update ] make_cfg: func [/local cfg] [ cfg: compose/deep [ ; comment info "Archiver prefs file" version 0.0.1 general [ archive (get-face field-archive) archiver (get-face field-archiver) command (trim get-face field-command) temp (trim get-face field-temp) ] files [ ] ] new-line/all text-list-files/data cfg/files: text-list-files/data cfg ] ask_close: func [] [ either not saved? [ switch request/offset ["Exit without saving?" "Yes" "Save" "No"] main-window/offset + 100x100 reduce [ yes [quit] no [if save_file [quit]] ] ][ either get-face tog-exit [ quit ][ if request/confirm/offset "Exit now?" main-window/offset + 100x100 [quit] ] ] ] ; do do_command: func [/local temp fl result out] [ temp: build_tree fl: flash/with "Archiving..." main-window ;probe result: either system/version < 2.9.0 [call/wait/output get-face info-command out: copy ""][call/wait get-face info-command] delete-dir temp unview/only fl inform/offset layout [ space 2x2 below text bold (either result <> 0 ["An error occured"]["Output"]) across info-out: info 580x300 as-is out wrap edge [size: 1x1] pad -20 scroller info-out/size/y * 0x1 + 16x0 with [append init [redrag 150 / 300]] [scroll-para info-out face] key (escape) (0x0 - sp) [hide-popup] ] main-window/offset + 40x40 ] ; gui gui-edge: [color: 15.15.15 image: none effect: 'ibevel size: 1x1] set_file_field: func [face [object!] ext type /local previous file-name response] [ previous: get-face face file-name: switch type [ new [request-file/keep/only/save/filter ext] file [choose_file ext] dir [ file-name: request-file/keep/only/save/title/filter "Create a folder" "OK" ext response: true if all [not none? file-name exists? file-name] [response: request/offset rejoin [{File "} last split-path file-name {" already exists, overwrite it?}] main-window/offset + 100x100] if response <> true [file-name: none] file-name ] ] set-face face to-local-file any [file-name previous] saved?: not found? file-name update_archiver ] add_files: func [/dir /local files file] [ either dir [ files: any [request-dir/keep []] files: append clear [] files %/ ][ files: any [request-file/keep/title "Select files" "OK" []] ] forall files [ file: to-local-file first files if not find text-list-files/data file [ unless empty? text-list-files/data [ if empty? text-list-files/picked [append text-list-files/picked first text-list-files/data] ; security check ] append text-list-files/data file saved?: no ] ] append clear text-list-files/picked file show text-list-files/update file ] remove_selected: func [/local picked] [ if empty? text-list-files/data [exit] picked: find text-list-files/data first text-list-files/picked clear text-list-files/picked either tail? next picked [ ; is last line? append text-list-files/picked first back picked ][ append text-list-files/picked first next picked ] remove picked saved?: no show text-list-files/update ] save_list: func [/to file-name [file!] /local response files files-string] [ if empty? text-list-files/data [exit] if not file-name [ file-name: request-file/only/save if not file-name [exit] if exists? file-name [response: request rejoin [{File "} last split-path file-name {" already exists, overwrite it?}]] if response <> true [exit] ] files-string: copy {} files: text-list-files/data forall files [ append files-string rejoin [{"} first files {"} newline] ] write file-name files-string ] update_archiver: func [/local command] [ command: reform [ enquote trim get-face field-archiver trim get-face field-command enquote trim get-face field-archive enquote trim get-face field-temp ] set-face info-command command ] sort_list: func [/reverse] [ either reverse [ sort/reverse text-list-files/data ][ sort text-list-files/data ] show text-list-files/update ] move_selected: func [/up /local picked selecting] [ if empty? text-list-files/data [exit] picked: text-list-files/picked if none? first picked [change picked first text-list-files/data] if none? selecting: find text-list-files/data first picked [exit] change picked either up [ any [first back selecting first text-list-files/data] ][ any [attempt [first next selecting] last text-list-files/data] ] show text-list-files/update ] main-layout: [ do [sp: 4x4] origin sp space sp Across style btn btn 90x24 style field field edge gui-edge style text text 150x24 para [origin: 0x3] btn "Load..." [open_file] btn "Save" [save_file] pad (-1x0 * sp) btn "as..." 36 [save_file/as] pad 100x0 - 36x0 btn "?" 20 sky keycode [f1] move-x [ ssh: System/script/header if not value? 'help-win [; avoid opening win more then once help-win: view/new layout [ below space sp style text text 500 center text bold ssh/Title text rejoin ["Version: " ssh/Version either ssh/Version <> pick tail ssh/history -2 [rejoin [" (" pick tail ssh/history -2 ")"]][""] " , " ssh/Date ". Copyright (C) " now/year " " ssh/Author] text bold "USE AT YOUR OWN RISK" text "END USER LICENCE AGREEMENT" blue underline [browse http://creativecommons.org/licenses/by-nd/3.0/legalcode] across info-help: info 580x300 as-is trim/auto ssh/Help wrap edge [size: 1x1] pad -20x0 scroller info-help/size/y * 0x1 + 16x0 with [append init [redrag 250 / 300]] [scroll-para info-help face] key (escape) (0x0 - sp) [unview/only help-win unset 'help-win] ] help-win/feel: make help-win/feel [ super-detect: :detect detect: func [face event][ super-detect face event if event/type = 'close [unview/only face unset 'help-win] event ] ] ] ] tog-exit: tog "Now" 36x24 off move-x pad (-1x0 * sp) btn "Exit..." move-x [ask_close] return text "Archive:" 60 field-archive: field "test.zip" 330 resize-x [update_archiver] btn "..." 40 move-x [set_file_field field-archive "*.zip" 'new] return text "Archiver:" 60 field-archiver: field "7z.exe" 330 resize-x [update_archiver] btn "..." 40 move-x [set_file_field field-archiver "*.*" 'file] return text "Archiver commands and options:" 190 field-command: field "a -tzip" 200 resize-x [update_archiver saved?: no] return text "Temporary directory:" 190 field-temp: field "backup" 200 resize-x [update_archiver saved?: no] btn "..." 40 move-x [set_file_field field-temp "*.*" 'dir] return text bold "Command:" return info-command: info "7z.exe a -tzip test.zip temp\" 394 resize-x btn "Do" 40 green move-x [do_command] return text bold "Directories and files:" return text-list-files: text-list 437x200 resize-xy with [ ;-- The update function. This should be called by user code when the ; list has been changed. It will recompute scroll bar variables. ; Return the list face so user can write: SHOW alist/update update: func [/local item tot-rows visible-rows] [ tot-rows: length? data visible-rows: lc sld/redrag visible-rows / max 1 tot-rows sld/page: sld/ratio / 1.5 if item: find data picked/1 [ either visible-rows >= tot-rows [ sld/step: 0.0 sld/data: 0.0 sn: 0 ][ sld/step: 1 / (tot-rows - visible-rows) sld/data: (index? item) / tot-rows ; simple but it works if sld/data < sld/step [sld/data: 0] sn: to-integer sld/data / sld/step ] ] self ] ;-- Resize function. Change all sub-faces to new size. resize: func [new /x /y /local tmp][ either any [x y] [ if x [size/x: new] if y [size/y: new] ][ size: any [new size] ] pane/size: sz: size sld/offset/x: first sub-area/size: size - 16x0 sld/resize/y size/y iter/size/x: first sub-area/size - sub-area/edge/size lc: to-integer sz/y / iter/size/y sld/redrag lc / max 1 length? data sld/page: sld/ratio / 1.5 self ] ] return style btn btn 217 btn "Add dir..." [add_files/dir] resize [0 1 .5 0] ; must put resize block after first block for compatibility reasons since below I could remove word 'resize btn "Add file..." [add_files] resize [.5 1 .5 0] return btn "Sort A-Z" [sort_list] resize [0 1 .5 0] btn "Sort Z-A" [sort_list/reverse] resize [.5 1 .5 0] return btn "Delete selected" [remove_selected] resize [0 1 .5 0] btn "Save files list..." [save_list] resize [.5 1 .5 0] key (escape) (0x0 - sp) [ask_close] key keycode [down] (0x0 - sp) [move_selected] key keycode [up] (0x0 - sp) [move_selected/up] key #"^~" (0x0 - sp) [remove_selected] ] ; keep working if resizer not found if not value? 'resizer-ctx [remove-each word main-layout [any [word = 'move-x word = 'resize word = 'resize-x word = 'resize-y word = 'resize-xy]]] main-window: layout main-layout main-window/user-data: reduce ['size main-window/size] update_archiver insert-event-func func [face event /local siz] [ if event/face = main-window [ switch event/type [ close [ if event/face = main-window [ ask_close return none ] if all [value? 'help-win event/face = help-win] [unset 'help-win] event ] scroll-line [either event/offset/y < 0 [scroll-drag/page/back text-list-files/sld] [scroll-drag/page text-list-files/sld]] ] ] event ] ; main job-name: none named: no saved?: yes main-title: join copy System/script/header/title " - Untitled" min-size: main-window/size view/title/options main-window main-title reduce ['resize 'min-size min-size + system/view/title-size + 8x10 + system/view/resize-border] do-events ] ; err?