rebol [
	; -- basic rebol header --
	file:		%encompass.r
	version:	1.0.3
	date:		25-Nov-2003
	author:		"Maxim Olivier-Adlhoch"
	title:		"encompass function"
	purpose: 	"Patch/Extend/Restrict any function by transparently enclosing it within another."


	; -- rebol.org header --
	library: [
	        level: 'advanced
	        platform: 'all
	        type: 'function
	        domain: [extension patch]
	        tested-under: [view 1.2.10 w2k]
	        support: none
	        license: [lgpl]
	        see-also: none
	    ]
	

	
	; -- extended rebol header --
	notes: "Remove example at the end when using it in your code"
	copyright:	"Copyright (c) 2003 Maxim Olivier-Adlhoch"
	web: "http://www.rebol.it/~steel"
	e-mail: "moliad@aei.ca"
	original-author: "Maxim Olivier-Adlhoch"
	history: {
		v1.0.0:
			-basic functionality works
		v1.0.1:
			-encompassing function now always returns a value.
			-/silent prevents enclosed function from assigning a value to rval
			-/args can now add your own parameters and refinements to spec of enclosed function
			-/rval always added to spec
			-/local will now be removed from enclosed function's spec along with all local variables it defines.
				use /args to add your own.
		v1.0.2:
			-totally rewritten code.  integrated all 3 loops into 1
			-fixed a bug with /local handling
			-changed debug output
			-changed example code, to make it more obvious
		v1.0.3:
			-added missing local words in function!'s locals block

	}
	license:   {This tool is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation;
version 2.1 of the License.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

you can also get a complete copy of this license at
http://www.opensource.org/licenses/lgpl-license.php
}
	disclaimer: {
This tool is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.
}
]


;--------------------------
;- encompass
;------
; enclose a specified function within a new function with optional leading and trailing processing.
; it will safely carry over only refinements which are really used and you can even supply your own (which
; stay local to the encompassing function).
; note that in any case, a refinement called rval is always added to template, in order to create a local variable used by returns.
encompass: function [
	func-name [word!] "the name of a function to encompass, specified as a word. Must exist in global namespace."
	/args opt-args [block!] "a block of optional args which your pre or post processing will use.  These are, of couse, not sent to enclosed function."
	/pre pre-process "code you want to execute BEFORE the enclosed function. context is kept, so it is safe with objects."
	/post post-process "code you want to execute AFTER the enclosed function. context is kept, so it is safe with objects."
	/silent "notify that the enclosed function DOES NOT return a value (like print). Rval is still returned and will be none by default, unless your post process plays with it."
	/debug "prints out various data and makes enclosed function print itself before execution"
][
	; local variables
	blk dt func-args func-ptr func-body last-ref item params-blk refinements word arguments args-blk][
	if debug [
		print "^/^/----------------------------------------------------------------------"
		print "encompass()^/"
	]
	
	;----------------
	; find function to override
	;----------------
		func-ptr: get in system/words func-name
	
	;----------------
	; make sure we really have a function to work with
	;----------------
		if not any-function? :func-ptr [print "  error... funcptr is not a function value or word" return none]
	
	;----------------
	; reconstruct args block
	;----------------
		arguments: third :func-ptr ; get enclosed function's arg block
		func-args: copy []   ; the actual block which will be used for sub-func
		last-ref: none
		
		; prepare function...
		args-blk: copy compose [
			([('system)])
			([('words)])
			(to paren! to-lit-word func-name)
		]
		params-blk: copy [] ; stores all info about the params
		
		; prepare datablocks to construct path
		FOREACH item arguments [
			; block values in arguments are always datatype casting specifications
			SWITCH/default TYPE?/word item [
				block! [
					; change all datatype values into word values.
					blk: copy []
					FOREACH dt item [
						word: MOLD dt
						APPEND blk TO-WORD word
					]
					APPEND/only func-args blk
				]
			
				refinement! [
					last-ref: item
					; never include local word setup, this is local to enclosed function...
					if last-ref <> /local [
						APPEND func-args item
						append/only args-blk to paren! compose/deep [either (to-word item) [(to-lit-word item)][]]
					]
				]
			
				word! [
				
					either last-ref [
						; never include local word setup, this is local to enclosed function...
						if last-ref <> /local [
							append/only params-blk to paren! copy compose/deep [either (to-word last-ref) [(item)][]]
							append func-args item
						]
					][
						append/only params-blk to paren! item
						append func-args item
					]
					
				]
			][
				; default block
				append func-args item
			]
		]


	;----------------
	; actually create function body
	;----------------
		; currently only supports global namespace words. 
		; using this  system/words/ notation, prevents circular references when using methods
		; in objects which have the same name as the one which is in global namespace :-)
		
		; nest refinement and parameters into various paren and blocks to create actual function call
		blk: append append/only copy [] to paren! compose/deep [ to-path compose [(args-blk)]] params-blk
		
		;func-body: insert copy [] 
		
		;create outer body block,
		func-body: append copy [] compose [
			;include pre-process (if any)
			(either pre [pre-process][])
			; in debug mode this prints the final internal function call, just before calling it
			enclosed-func: (either debug ['probe][])
			; add main function body, created above
			compose (append/only copy [] blk)
			; user wants the internal command's returned value (rval:)
			(either silent [][to-set-word 'rval])
			; call the dynamically generated command.
			do enclosed-func
			; insert post-process (if any)
			(either post [post-process][])
			; add the return statement
			return rval
		]
		
	;----------------
	; add optional arguments which your pre or post processing might need...
	;----------------
		if args [
			; find point where parameters end and refinements start
			refinements: find func-args refinement!
			either refinements[
				func-args: refinements
			][
				; there are no refinements, so we add to the end
				func-args: tail func-args
			]
			insert func-args opt-args
		]
		
		append func-args [/rval]
		func-args: head func-args
		
	;----------------
	; debug information
	;----------------
		if debug [
			print "^/FUNCTION ARGUMENT SPEC:"
			probe func-args
			
			print "^/FINAL FUNCTION BODY:"
			probe func-body
			print "----------------------------------------------------------------------^/^/"
		]
		return func func-args func-body
]



;----------------
;--- examples ---
;----------------

; patches 'READ function so that it warns you of all file reads and asks confirmation.
old-read: :read
read: encompass/args/pre 'old-read [/safe] [
	if not safe [
		print "----------------- WARNING! --------------------"
		print "--                                           --"
		print "--         FILE READ ABOUT TO OCCUR          --"
		print "--                                           --"
		print "-----------------------------------------------"
		print ["-- path:" clean-path source]
		print "-----------------------------------------------"
		answer: ask "authorize (Y/N)?"
		if answer <> "Y" [
			ask "APPLICATION ABORTING, USER DID NOT ACCEPT FILE READ^/^/press enter to quit!^/^/"
			quit
		]
	]
]


; this shows that you do not have to know about any refinement or argument from source function
; in order to patch it.
print read/part %encompass.r 126

ask ""