Script Library home

  Find scripts   Help
  Go to script:

New and updated
Popular scripts
 Discussions
 Scripts with documentation
 First time here?
 Terms
Tag indexApplications
 Demos · Games
 Tools
 How-to · FAQ
 Tutorials · Idioms
Code
 1-liners · Functions
 Modules · Internet
 CGI · FTP
 Mail · UI / GUI
 Database · Files
 Text · Markup
 HTML · Protocols
 Dialects · Math
 Games · Patches
 Packages

All scriptsBeginner
Intermediate
Advanced
Recent searches
Download: desktop
AccessibilityAbout / FAQ
Member's loungeContact/FeedbackOther REBOL links
Membership:
member name

password

Remember?

Not a member? Please join
19-Apr 13:42 UTC
[0.045] 23.527k
Script Library: 1238 scripts
  • Home
  • Script library
  • AltME Archive
  • Mailing list
  • Articles Index
  • Site search
 
<<Previous · Next>>  |
View discussion [50 posts]View scriptLicense
Download scriptHistoryOther scripts by: luce80

Archive version of: mini-edit-do.r ... version: 9 ... luce80 14-Aug-2012

Amendment note: Fixed ctrl+X and save after clear all, arg1, do-face || Publicly available? Yes

REBOL [
	title: "Mini-edit-do"
	file: %mini-edit-do.r
	author: "Marco Antoniazzi"
	Copyright: "(C) 2012 Marco Antoniazzi. All Rights reserved"
	email: [luce80 AT libero DOT it]
	date: 09-08-2012
	version: 0.5.9
	Purpose: "Helps test short programs (substitutes console)"
	History: [
		0.0.1 [30-04-2012 "First version"]
		0.5.1 [01-05-2012 "Fixed using view and quit"]
		0.5.2 [05-05-2012 "Added undo and redo"]
		0.5.3 [10-05-2012 "Fixed last probe"]
		0.5.4 [12-05-2012 "Added halt and other minor fixes"]
		0.5.5 [20-05-2012 "Fixed error inside prin and script header"]
		0.5.6 [03-06-2012 "Fixed bug when deleting all"]
		0.5.7 [08-06-2012 "Fixed undo after clear all"]
		0.5.8 [29-07-2012 "Fixed arg1 etc. in err?"]
		0.5.9 [09-08-2012 "Fixed ^X and save after clear all, arg1, do-face"]
	]
	comment: {30-Apr-2012 GUI automatically generated by VID_build. Author: Marco Antoniazzi.
		Derived directly from ParseAid.r
	}
	library: [
		level: 'intermediate
		platform: 'all
		type: 'tool
		domain: [debug testing]
		tested-under: [View 2.7.8.3.1]
		support: none
		license: 'BSD
		see-also: %parse-aid.r
	]
	todo: {
		- options: 
			- set max area-results length
			- set max dumped obj length
			- choose between head or tail of dumped obj
		- patch ALL functions to use err? (to output error to my prog)
	}
]

	err?: func [blk /local arg1 arg2 arg3 message err][;derived from 11-Feb-2007 Guest2
		if not error? set/any 'err try blk [return get/any 'err]
		err: disarm err
		arg1: any [attempt [get in err 'arg1] 'unset]
		arg2: get in err 'arg2
		arg3: get in err 'arg3
		message: get err/id
		if block? message [bind message 'arg1]
		prin* ["**ERROR:" form reduce message newline]
		prin* ["**Near:" either block? err/near [mold/only err/near][err/near] newline]
		throw
	]
; patches
	old-length: 0
	old-prin: :prin old-print: :print ; use these to output to console
	old-probe: func [value] [old-print mold :value :value]
	old-quit: :quit
	quit: does [
		; closing all windows (except ours) is similar to quitting ...
		foreach face next System/view/screen-face/pane [unview/only face]
	]
	halt: does [] ; avoid opening console
	prin*: func [value][
		set-face/no-show area-results append get-face area-results form reduce value
		system/view/vid/vid-feel/move-drag area-results/vscroll/pane/3 1 ; autoscroll down
	]
	prin: func [value] [
		either (100000 + old-length) > length? get-face area-results [ ; avoid fill mem
			set-face/no-show area-results append get-face area-results form err? [reduce value]
			system/view/vid/vid-feel/move-drag area-results/vscroll/pane/3 1 ; autoscroll down
			wait 0.0001 ; avoid blocking the gui
		][
			alert "ERROR. Probable infinite loop."
			reset-face area-results
			throw
		]
		exit ; force unsetting result
	]
	print: func [value] [prin value prin newline]
	probbed: none
	probe: func [value] [probbed: get 'value print mold :value :value]
	*isolator: context [
		func: make function! [
		    "Defines a user function with given spec and body." 
		    [catch] 
		    spec [block!] {Help string (opt) followed by arg words (and opt type and string)} 
		    body [block!] "The body block of the function"
		][
		    throw-on-error [make function! spec compose/deep [err? [(body)]]]
		]
		view: func ; taken from "REBOL Word Browser (Dictionary)" Author: "Carl Sassenrath"
			first get in system/words 'view
			head insert copy/deep second get in system/words 'view [new: true]
	]
	do-face: func [face value] [ ; (needs to work for functions and blocks)
		err?[do get in face 'action face either value [value][face/data]]
	]
	do-face-alt: func [face value] [
		err?[do get in face 'alt-action face either value [value][face/data]]
	]
	ctx-text/next-word: func [str /local s ns] [
		s: charset " ^-^/^M" ns: complement s
		any [all [s: find str s find s ns] tail str]
	]
	ctx-text/back-word: func [str /local s ns] [
		s: charset " ^-^/^M" ns: complement s
		any [all [ns: find/tail/reverse str ns ns: find/reverse ns s next ns] head str]
	]
;
context [ ; protect our functions from being redefined
; file
	change_title: func [/modified] [
		clear find/tail main-window/text "- "
		either modified [append main-window/text "*" saved?: no][saved?: yes]
		append main-window/text to-string last split-path any [job-name %Untitled]
		main-window/changes: [text] show main-window
	]
	open_file: func [/local file-name job] [
		until [
			file-name: request-file/title/keep/only/filter "Load a Rebol file" "Load" "*.r"
			if none? file-name [exit]
			exists? file-name
		]

		job-name: file-name
		job: read file-name
		set-face area-test job
		code: copy job

		named: yes
		change_title
		saved?: yes
	]
	save_file: func [/as /local file-name filt ext response job] [
		;if empty? job [return false]
		if not named [as: true]

		if as [
			filt: "*.r"
			ext: %.r
			file-name: request-file/title/keep/only/save/filter "Save as Rebol file" "Save" filt
			if none? file-name [return false]
			if not-equal? suffix? file-name ext [append file-name ext]
			response: true
			if exists? file-name [response: request rejoin [{File "} last split-path file-name {" already exists, overwrite it?}]]
			if response <> true [return false]
			job-name: file-name
			named: yes
		]
		flash/with join "Saving to: " job-name main-window

		job: get-face area-test
		write job-name job
		code: copy job

		wait 1.3
		unview
		change_title
		saved?: yes
	]
; do
	test: func [/local text script result temp] [
		if get-face check-clear-res [reset-face area-results old-length: 0]
		err? [
			probbed: none
			text: copy get-face area-test
			script: attempt [load/header text]
			if none? script [script: load text insert script make system/script/header [] ]
			system/script/header: script/1 ; replace our header with the script's one
			doing: true
			set/any 'result do bind script *isolator
			doing: false
			text: none recycle
			old-length: old-length + length? get-face area-results
			if not unset? get/any 'result [
				if any-function? :result [if not equal? :probbed :result [probe mold :result] exit]
				if object? result [
					if 10000 < length? temp: mold/only result [result: copy/part temp 10000 append result "..."]
				]
				if not equal? probbed result [probe result]
			]
		]
	]
; gui
	;do %area-scroll-style.r ;Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
	do decompress ; %area-scroll-style.r Copyright: {GNU Less General Public License (LGPL) - Copyright (C) Didier Cadieu 2004} 
		64#{
		eJztWUuP5LYRvutXMJ3D2gvIml4bgSHsZg65+OJbYCwg9BgciWopq5Y6Enu6J0H8
		2/NVFUlR3T0vZ4NcYsMekawq1otVH9mJHo1OJ/vYmVzRn/YfRhWJzJbj0HW5ooE6
		trbBwqGvhlxVg5lUoceMhhuVjGYxS0PM1u0pnbq2MmO616POVX3oS8hY7YYHo7SS
		NaXLchirtt8qa05W1a3pKiV7Y/K7lUpsrVaypkuD8YSxMGdCByluifYe9VatdDcN
		yg1sY9QZPZF2Q6k7ZXd70sWqdko20K6tVT/05lbZOiO1VWFOrYU57ZTT3EQeSpWp
		tialbyKEirt9rnZtr9anNSSBwLFnOz1uMT9PDGMrE5OFyyEhZdtICnw01Zk+QQCM
		zCptMbPTJ3UjsoMMMSPLtcqUQWTgAGhA449/BnEhA5izJsVr74gCQt2nyGsnkUF7
		rKEQMyVTMxyhCNyBRMjVg0+Exn9MXZ2zl0DLU+mxrWyTq/WfVHJENOEqvd+bvlK6
		f1QFT6ly2ON7Q052IlXRm2MW5NvxgLwYtxM2bmKK5hqFD6XsrQqY2fbWbM14yyTZ
		B2FeaigrG9WTz50k5HeVDn0H7epOb1PKJRAc1bzgKIeDxYYU+3PSaIVp2XllaaaJ
		IvjFKBnA9slYZnvvDwTLeNDdwZBraJRzOmd6VIl8MG8WONXM4ihqY7pMV387TNad
		uUmIkrIzWo4Hn9a0a5Hr8SydVp4llbfXlNvIH+iTUapuHPtVwnP9+ThZZXZ7+3gr
		05zuTmJV/WqHX2fFoMwBWhfvRuQjJ8zM0pl+a5tIyGaz9E+klTP+Wd8kHPqr4Xgh
		EBHXGzaio34ZeJr223FxkaKA/ObvMI2C8c0H9V4OlKaTwUucceErE2k3p5vNt+x7
		XgmnLYmH2VDXMCM7yYbzX+wku0YHJ9nM4pqluGYp7tGJCX+fEudTKrb5QuOFwuJD
		SJQ/11RaaOToT86uaM+nIoW1RI6uVK+2by0dWap3k+lQove6h7aulLECXJCPo97f
		qiIUKiqOssyhukev+XILtm7ATh/Up5DMMoUEcDs6kvWPN9+5/0jtUGpYCRpOQUfS
		SFGdpjKTiqv3ppSkecfNGxY8IOumx8maXfbQol4l4cxF1oRSEM2dH1GfvLq0zq4/
		bFzfXN/gH/Ux2DYf62I03PTvdflFWd128xp5qZ/MaDMutA1KbsTIatBWrmItipWA
		kUZPrI1TwlWaaG/Xv0GCBkKlOKqDF1uHDWRX+C0r4UNq1YBAZQN8MrpFbOcNo66M
		SSsQBotoPvT/H8ipaE28y5X17znZrmUjlRwOKO+ePrRTe98h/l4f36W7OgkA7Lon
		ZosuPTGvPReE13niGSPZCS956ut44pLSJyxPOtcII7ASWyoNKSntiaEYKmlrBZRh
		73LY7YcJLWlq2tqqb2ogS/MtpnuLox7GXwzcNuyolG8WzuKUd4r+xzsAOjZkw0aq
		1E73GjBUzoFYSVQO2QIfqLLbA9aRy1EqnPFckcpGAycR9R9Xd39ZkS8wYGymUb+C
		pk3b0Z63KnE4k7lJNPg+r1DJHBtqPyyYtzqXkI663wItXxSUuOe3fWVOt05jOvuS
		LkGskiZzG9nEoN3pRkiDVIM2nKJZZWp96CzbWSTQ+KcVA0WMc7VvERkOz5xLaxyg
		l/U7YyLp6w2hEezw2/kObxX+hNyfV89xt5fc4MlWxM/sv7yVHZmTMwDGV7u/H/RY
		5Vk2961u7yR/flZywHELCCfojUP3JqXEI4lw/q8yLoDaGsyqkKySyEuc2N0bl3Sv
		sY9Fe9tYvETs01tlvCJoSfiX2kanranibl/aduj9XR41NZMZAR4O/dMfvgQKLk/k
		nkpj+lIJ7u3GYQWaDENCT6Oj5Kt1Qpg19zfYgHJuiSK+URUCp1gfmqBOgeookugL
		pZVxk8w4DLUEcQyaHAfjJ69FzgjONR93WVsUanXPcZ6viWnddtAtR4sk17DzAgci
		NqV2SF07pDpLifrPu5/u0rvf7n6++3z3y91f/8U9e9THxV2AeilaQVyncU3npXfO
		KIckGeYF7JjMw+BNLQh99imLmW+036uPn5ZXKhHHR4sLVzQplaxYK/RyloN2EaFJ
		xAANJ3V3nSvsL/FIOkIZvTUXHjEPBhF2TQ0Ygkr8JtR4B0Cq4diL285NrtpJAwZU
		Af7MzSI1fz/oztGRUu8jrch7Q3kIVzjBVKRLVg0HSExxxsgr19o6C3ipsdNrhvT1
		ztRWkMNrZQnvFVEBIsBQ2JvMBovuwl/4GiZWN2CSmil1pLg6nTtqh6SScyIcttzV
		SzoBUrJZe9laltiVwcxDL7w0kCyI9niFNHenG1HHwpMUwUF/7wbkHIO1Pt7RFq/Y
		4b/nq69pKt9aj/rRVwMh+wEgcXiQp8mFLH5VPN0sJ9PouUFwYPz8wN/LN815Krxq
		vvWRYhbh786kK6lGKhKaS6NXUnbKOQsoqCz8Xh/jEKGTn/n6wtgLUyNXhTAQ1rj6
		/HPYu+LkQ+M8EwUzCOFQ2nZHFYiDdy1G0ASTct336REiTd7wAabv/8f1Fe77yhEX
		5OYqh7jsyV4slzHRk/gYWJ7DjXmdCmh09YsYk7OuIa1zC+sCjnB47rravhMvF89f
		RmFUDEMciuR+CaXRkuk3leXS2W9B/lcIVgnUfmNo6TuDekeQE3M+kV22IsZ73Y4B
		AvvuFp4M43dGaHszN8DmSZIkIEoHojyclDLr8X4EUM0ZQhUk6579DtSo+SUi/D6F
		psCYhZFySPvwtuHpvKtBotrqpDJyJUO8afHARw+a9MoHL4UdwFLMkJ5EezR/5XcG
		5wKG4YtQhQoUPy/OYJp/3hNK+pHKXVfmF+bwY87SfD1J1GLPK/f4mz2qD07O/LTc
		PC/Hs56WEtdOjnv6ipQt5u8Qpvk1PzzNS2Bp7A/DvwHDTPC9Ih0AAA==
		}
	rezize-faces: func [siz [pair!] /move] [
		text-results/offset: text-results/offset + (siz * 0x1)
		area-results/offset: area-results/offset + (siz * 0x1)
		resize-face/no-show area-test area-test/size + (siz * 1x1)
		resize-face/no-show area-results area-results/size + (siz * 1x0)
		if move [
			resize-face/no-show area-results area-results/size + (siz * 0x-1)
		]
	]
	feel-move: [
		engage-super: :engage
		engage: func [face action event /local prev-offset] [
			engage-super face action event
			if find [over away] action [
				prev-offset: face/offset
				face/offset: 0x1 * (face/old-offset + event/offset) ; We cannot modify face/old-offset but why not use it?
				face/offset: 0x1 * second confine face/offset face/size area-test/offset + 0x100 area-results/offset + area-results/size - 0x100
				face/offset: face/offset + 4x0 ; ?? must add spacing

				if prev-offset <> face/offset [
					rezize-faces/move (face/offset - prev-offset * 0x1)
					show main-window
				]
			]
		]
	]
	main-window: center-face layout [
		styles area-style
		do [sp: 4x4] origin sp space sp
		Across
		btn "(O)pen..." #"^O" [open_file]
		btn "(S)ave" #"^S" [save_file]
		pad (sp * -1x0)
		btn "as..." [save_file/as]
		btn "Undo" #"^z" [area-test/undo if strict-equal? code get-face area-test [change_title]]
		btn "(R)edo" #"^r" [area-test/redo if strict-not-equal? code get-face area-test [change_title/modified]]
		btn "(D)o script" #"^D" yellow [test area-test]
		btn "H(a)lt" #"^A" red [if doing [doing: false make error! "Halt"]]
		btn "Clear (T)est" #"^T" [if confirm "Are you sure?" [clear-face area-test job-name: none named: no change_title/modified]]
		btn "Clear R(e)sults" #"^e" [clear-face area-results old-length: 0]
		pad 0x1
		check-clear-res: check-line "before every do"
		return
		Below
		style area-scroll area-scroll 650x200 hscroll vscroll font-name font-fixed para [origin: 2x0]; Tabs: 16]
		text-test: text bold "Test"
		area-test: area-scroll {print "Hello world!"} with [append init [deflag-face self/ar 'tabbed ]]
		button-balance: button "-----" 650x6 gray feel feel-move edge [size: 1x1] font [size: 6]
		text-results: text bold "Results"
		area-results: area-scroll silver read-only
		key escape (sp * 0x-1) [ask_close]
		do [
			code: copy area-test/text
			old-add_to_undo-list: get in area-test/ar 'add_to_undo-list
			area-test/ar/add_to_undo-list: func [key] [change_title/modified old-add_to_undo-list key]
		]
	]
	main-window/user-data: reduce ['size main-window/size]
	insert-event-func func [face event /local siz] [
		if event/face = main-window [
			switch event/type [
				close [
					ask_close
					return none
				]
				resize [
					face: main-window
					siz: face/size - face/user-data/size     ; compute size difference
					face/user-data/size: face/size          ; store new size

					rezize-faces siz
					button-balance/offset: button-balance/offset + (siz * 0x1)
					button-balance/size: button-balance/size + (siz * 1x0)
					show main-window
				]
				scroll-line [either event/offset/y < 0 [scroll-drag/back/page area-test/vscroll] [scroll-drag/page area-test/vscroll]]
			]
		]
		event
	]
	ask_close: does [
		either not saved? [
			switch request ["Exit without saving?" "Yes" "Save" "No"] reduce [
				yes [old-quit]
				no [if save_file [old-quit]]
			]
		][
			if confirm "Exit now?" [old-quit]
			;old-quit
		]
	]
; main
	doing: false
	
	job-name: none
	named: no
	saved?: yes
	main-title: join copy System/script/header/title " - Untitled"
	view/title/options main-window main-title reduce ['resize 'min-size main-window/size + system/view/title-size + 8x10 + system/view/resize-border]
] ; context
Notes