Archive version of: archiver.r ... version: 1 ... luce80 17-Apr-2016

Amendment note: new script || Publicly available? Yes

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: 11-04-2016
	version: 0.8.1
	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"]
	]
	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 %resizer.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?