|
|
|
AnaMonitor Browser - Source CodeA REBOL object and block browser. |
|
REBOL [
Title: "AnaMonitor"
Version: 2.0.0
File: %AnaMonitor.r
Email: rotenca@libero.it
Author: "Romano Paolo Tenca"
Copyright: {GNU General Public License - Copyright (C) Romano Paolo Tenca 2001-2003}
Web: http://www.rebol.it/~romano
Rights: {
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program 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 General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software Foundation
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
Aknowledgments: {Thanks to Gabriele Santilli for its beta testing and its support}
Beta: false
History: [
[2.0.0 27-Feb-2003 "Second major public release"]
[1.1.0 2-Nov-2001 "First public release"]
]
Date: none
Category: [vid view utils 2]
Purpose: {
^-^-A debugging tool to visually examine Rebol values.
^-}
]
context [
set 'win-offset? func [
{Given any face, returns its window offset. Patched by Romano Paolo Tenca}
face [object!]
/local xy
] [
xy: 0x0
if face/parent-face [
xy: face/offset
while [face: face/parent-face] [
if face/parent-face [
xy: xy + face/offset + either object? face/edge [face/edge/size] [0]
]
]
]
xy
]
system/view/wake-event: func [port /local event no-btn p-f] bind [
event: pick port 1
if none? event [
if debug [print "Event port awoke, but no event was present."]
return false
]
awake event
] in system/view 'self
awake: func [event /local no-btn p-f] bind [
either not p-f: pop-face [
do event
empty? screen-face/pane
] [
either all [
event/type = 'key
event/key = escape
] [hide-popup] [
either any [
p-f = event/face
all [
event/face
same? p-f/parent-face find-window event/face
within? event/offset win-offset? p-f p-f/size
]
] [
no-btn: false
if block? get in p-f 'pane [
no-btn: foreach item p-f/pane [if get in item 'action [break/return false] true]
]
if any [all [event/type = 'up no-btn] event/type = 'close] [hide-popup]
do event
] [
either p-f/action [
if not find [move time inactive] event/type [
hide-popup
]
if find [time inactive resize close] event/type [do event]
] [
if find [resize offset time] event/type [do event]
]
]
none? find pop-list p-f
]
]
] in system/view 'self
free: true
set 'eat func [/only blk [block!]] [
if free [
free: false
any [only blk: [move]]
until [
only: pick system/view/event-port 1
not all [only find blk only/type]
]
if only [awake only]
free: true
]
]
]
anamonitor-ctx: context [
window-mins: [subface 300x100 ly-exe 300x200 ly 600x430]
basecol: aqua
backcol: pewter
view*: system/view
wnum: 0
stopmode: false
h: none
out-range: "(out-of-range)"
clickme: "(click me)"
header: make system/script/header [
set [Version Date] first history
license: none
]
find-into: func [
"Find inside a block"
series value /part range /only /case /any /with wild /skip size /match /tail /last /reverse /local f
] [
f: refine [find first series value] [[part range] only case any [with wild] [skip size] match tail last reverse] [return tmp]
while [not tail? series] [
if do f [return index? series]
series: next series
]
none
]
switch-m: func [
{Selects a choice and evaluates the first block! which follows it.}
[throw]
value "Value to search for."
cases [block!] "Block of cases to search."
/default case "Default case if no others are found."
] [
either value: find cases value [
until [block? first value: next value]
do first value
] [either default [do case] [none]]
]
rejoin: func [
"Reduces and joins a block of values."
block [block!] "Values to reduce and join"
/with value
] [
if empty? block: reduce block [return block]
if with [parse/all block [any [skip with: skip (insert with :value)]]]
head insert tail either series? first block [copy first block] [form first block] next block
]
rig: func [data num [integer!]] [
data: to string! data
head insert/dup data " " max 0 num - length? data
]
lef: func [[catch] data num [integer!]] [
data: to string! data
head insert/dup tail data " " max 0 num - length? data
]
as-pair: func [blk] [to pair! reduce blk]
set 'find-ref func ["Search references to/thru a given value"
[catch]
target "Value to find"
/cont {Start the search from this object (default: system/words)} ctx [object!]
/circ "Print also circular references"
/only "Return only the first path found"
/body "Search also in function body"
/result "Return result in a block"
/exclude "Exclude from search" custom [block!]
/local delayed delayedp past pastn print inof form-path same? visited res
] [
print: func [x] [all [not result system/words/print :x]]
form-path: func [x] [replace/all form :x " " "/"]
same?: func [a [any-type!] b [any-type!]] [
if all [error? :a error? :b] [return (disarm :a) = disarm :b]
if any [error? :a error? :b] [return false]
not error? try [return system/words/same? :a :b]
]
inof: func [
item [object! block! paren! function!] name [string!] target
/local names values fin fiv ret trovati tmp
] [
if find/only visited :item [return false]
insert/only tail visited :item
either object? :item [
names: next first :item
values: next second :item
] [
if function? :item [item: second :item]
if error? try [names: make block! length? :item] [return false]
repeat i length? :item [insert tail names i]
values: :item
]
insert/only tail past :item
insert tail pastn name
trovati: copy []
while [not tail? :names] [
if not unset? first :values [
fin: form first :names
error? fiv: first :values
if any [
all [
any-word? :target
object? :item
same? in :item first names :target
]
same? :fiv :target
either any-word? :fiv [
all [
value? :fiv
same? get/any :fiv :target
]
] [
all [
any-path? :fiv
any [
all [
any-word? :target
same? first :fiv :target
]
all [
any-path? :target
(length? :fiv) >= length? :target
equal? copy/part :fiv length? :target :target
same? first :fiv first :target
]
all [
value? first :fiv
same? get/any first :fiv :target
]
]
]
]
] [
insert tail trovati reduce [copy past copy head insert tail pastn fin]
print tmp: form-path next pastn
remove back tail pastn
insert tail res tmp
if only [return true]
]
if any [
block? :fiv
object? :fiv
paren? :fiv
all [body function? :fiv fin: join fin "/[BODY]"]
] [
either find past :fiv [
if circ [
insert/only tail delayed :fiv
insert/only tail delayedp join pastn fin
]
] [
all [ret: inof :fiv fin :target only return true]
]
]
]
names: next :names
values: next :values
]
remove back tail pastn
remove back tail past
if circ [
foreach [past pastn] trovati [
if not empty? past [
repeat i length? delayed [
if tmp: find past delayed/:i [
insert tail res tmp: form-path next join delayedp/:i skip pastn index? tmp
print ["^-" tmp]
]
]
]
]
]
:ret
]
custom: head insert tail copy [self cb :find-ref] any [custom []]
if all [only any [result circ]] [throw make error! "Invalid Refinements"]
insert insert tail visited: make block! 10000 reduce custom reduce [
visited past: make block! 25 pastn: make block! 25 res: make block! 100
]
if circ [insert insert tail visited delayed: make block! 100 delayedp: make block! 100]
any [cont ctx: system/words]
inof ctx either cont ["Context"] ["system/words"] :target
visited: pastn: custom: delayed: delayedp: none
either only [first res] [either result [:res] [none]]
]
set 'find-global func [f [function!] /local w out code] [
out: copy []
code: [if global? :w [if value? :w [if any-function? get :w [return]] insert tail out to-word :w]]
parse second :f r: [
any [
into r |
set w [word! | get-word! | set-word! | set-word!] (do code) |
set w [path! | set-path! | lit-path!] (w: first :w do code) |
skip
]
]
out
]
test-value: func [x [any-type!]] [
if not value? 'x [return -2]
if error? :x [return 0]
if all [any-block? :x error? try [tail? :x]] [return -1]
1
]
get-all: func [
"Get any value of a path or of a word"
w [path! set-path! lit-path! any-word!]
] [
either error? set/any 'w either any-word? :w [get/any :w] [get-path/anyv/ignore :w] [return :w] [:w]
]
get-path: func [
"Get the value of a path of a word"
path [path! set-path! lit-path!]
/anyv "Like /any in get/any"
/ignore "Ignore functions refinements"
/local b e get-in res
] [
get-in: func [p w [word! get-word! integer!]] [
if get-word? :w [
if error? try [w: get :w] [make error! reduce ['script 'no-value :w]]
]
any [
if all [integer? :w any-block? :p] [
if error? try [error? set/any 'res pick :p :w] [make error! reduce ['script 'out-of-range :w]]
true
]
if all [word? :w object? :p] [
if error? try [error? set/any 'res get/any in :p :w] [make error! reduce ['script 'invalid-path :w]]
true
]
if any [block? :p hash? :p] [
all [set-word? :w w: to-word :w]
if any [
not p: find :p :w
error? try [error? set/any 'res select :p :w]
] [make error! reduce ['script 'invalid-path :w]]
true
]
if any-function? :p [if ignore [return :p] false]
if find [pair! file! url! date! time! tuple! email! event! money! image! struct!] type?/word :p [
if error? try [return p/:w] [make error! reduce ['script 'invalid-path :w]]
true
]
make error! reduce ['script 'invalid-path :w]
]
if error? get/any 'res [return get/any 'res]
get/any 'res
]
b: first head insert/only copy [] :path
if error? try [error? e: get first :b] [make error! reduce ['script 'no-value first :b]]
while [b: next :b not tail? :b] [error? set/any 'e get-in :e first :b]
if all [not value? 'e not anyv] [make error! reduce ['script 'no-value :path]]
if error? get/any 'e [return get/any 'e]
get/any 'e
]
any-path?: func [x [any-type!]] [any [path? :x set-path? :x lit-path? :x]]
v-c: func [
x [any-word! path! lit-path! set-path!]
/local res b-x t
] [
res: copy []
if any-path? :x [
if empty? x: head :x [return res]
x: first :x
]
t: third :bind
change t/words reduce [block! any-word!]
change t/known-word reduce [any-word!]
foreach y first system/words [if not same? y b-x: bind y :x [insert tail res b-x]]
change t/words reduce [block! word!]
change t/known-word reduce [word!]
res
]
bindall: func [
"Binds words to a specified context."
words [block! any-word!] "A block of words or single word."
known-word [any-word!] "A sample word from the target context."
/copy "Deep copies block before binding it."
/local t res
] [
t: third :bind
change t/words reduce [block! any-word!]
change t/known-word reduce [any-word!]
res: either copy [bind/copy :words :known-word] [bind :words :known-word]
change t/words reduce [block! word!]
change t/known-word reduce [word!]
:res
]
inall: func [
"Returns the word in the object's context."
object [object!]
word [any-word!]
/local t res
] [
t: third :in
change t/word reduce [any-word!]
res: in object :word
change t/word reduce [word!]
:res
]
undefined?: func [x [any-word! set-path! lit-path! path!]] [
if any-path? :x [
if empty? x: head :x [return true]
x: first :x
]
error? try [error? get/any :x]
]
global?: func [x [any-word! set-path! lit-path! path!]] [
if any-path? :x [
if empty? x: head :x [return false]
x: first :x
]
same? :x first bind use reduce [:x] reduce [reduce [:x]] 'system
]
context?: func [x [any-word! set-path! lit-path! path!]] [
any [
if undefined? :x ["Undefined"]
if global? :x ["Global"]
"Local"
]
]
same-any?: func [x [any-type!] y [any-type!]] [
found? any [
all [not value? 'x not value? 'y]
all [
value? 'x
value? 'y
same? :x :y
]
]
]
equal-bc?: func [x y] [
if all [
equal? type? x type? y
equal? length? x: head x length? y: head y
] [
while [not tail? x] [
if not same-any? first x first y [return false]
x: next x
y: next y
]
if tail? y [return true]
]
false
]
type-any?: func ['x [word!] /word] [
either word [type?/word get/any :x] [type? get/any :x]
]
try-err: func [[throw] blk /local err] [
either error? set/any 'err try blk [
err: disarm err
print ["** Error: " reduce bind compose [(get err/id)] in err 'id]
print ["** Near: " err/near]
err
] [none]
]
confine: func [blk /local interrupt] [
interrupt: on
error? do does [error? loop 1 [error? catch [do blk interrupt: off]]]
interrupt
]
dump-as-style: func [
ss "Face to dump as style"
/name new [word!] "Use this name for the cloned style"
/local facets h
] [
if not name [new: 's]
either ss/facets [
parse/all facets: copy/deep ss/facets [
thru 'with into [
any [
thru words: into [
any [
h: function! (change/only h second first h)
| skip
]
]
]
]
]
compose [(ss/style) (facets)]
] [reduce [ss/style]]
]
charset-to-char: func [
"Converts charset to a block of commented chars"
data [bitset!]
/block "Return a block"
/local out
] [
out: make string! 1000
for i 0 255 1 [if find data i [insert tail out rejoin [mold to char! i " ; " i "^/"]]]
either block [to-block out] [out]
]
sub-set?: func [a b] [equal? a intersect a b]
charset-analyzer: func [
""
data [bitset!]
/local out print alpha num alphanum notalphanum ascii notascii
] [
out: make string! 1000
print: func [x] [insert tail out join x "^/"]
alpha: make bitset! [#"a" - #"z" #"A" - #"Z"]
num: make bitset! [#"0" - #"9"]
alphanum: union alpha num
notalphanum: complement alphanum
ascii: charset [#"^@" - #"^~"]
notascii: complement ascii
print either (length? charset-to-char/block data) < (- 24 + length? charset-to-char/block complement data) ["Charset include:"] [data: complement data "Charset exclude:"]
if sub-set? ascii data [data: difference data ascii print "^-All ASCII chars"]
if sub-set? notascii data [data: difference data notascii print "^-All not ASCII chars"]
either sub-set? alphanum data [print "^-Alphanum" data: difference data alphanum] [
if sub-set? alpha data [data: difference data alpha print "^-Alpha"]
if sub-set? num data [data: difference data num print "^-Num"]
]
if not equal? data charset "" [
print "^-Single chars: ["
print rejoin [charset-to-char data "]"]
]
out
]
my-styles: stylize [
btn: button 44 basecol edge [size: 1x1] with [
append init [
color: basecol
if :action [
action: func [f v /local x] compose [
all [x: not f/state f/state: on show f]
(:action) f v
eat/only [key]
if x [f/state: off show f]
]
]
if :alt-action [
alt-action: func [f v /local x] compose [
all [x: not f/state f/state: on show f]
(:alt-action) f v
eat/only [key]
if x [f/state: off show f]
]
]
]
]
tgl: toggle basecol edge [size: 1x1] with [
append init [
color: basecol
if :action [action: func [f v] compose [(:action) f v eat/only [key]]]
]
]
check: check feel [
o-e: :engage
engage: func [f a e /oc] [
oc: f/color
f/color: red
show f
o-e f a e
f/color: oc
show f
]
] with [
append init [
if :action [action: func [f v] compose [(:action) f v eat/only [key]]]
]
]
auto-panel: IMAGE with [
feel: none
size: -1x-1
append init [
insert action: second :action [origin 0x0]
pane: layout/parent/styles action self styles
if negative? size/x [size/x: pane/size/x + either edge [edge/size/x * 2] [0]]
if negative? size/y [size/y: pane/size/y + either edge [edge/size/y * 2] [0]]
pane: pane/pane
]
]
area-scroll: area edge [size: 1x1] with [
ar: sld: none
redrag: does [sld/state: none sld/redrag min 1 (second page-size) / second size-text ar]
page-size: does [ar/size - either ar/edge [2 * ar/edge/size] [0]]
resize: func [newsize /local delta] [
delta: newsize - size
size: newsize
ar/size: ar/size + delta
sld/offset: delta * 1x0 + sld/offset
either in sld 'resize [sld/resize delta * 0x1 + sld/size] [
sld/size: delta * 0x1 + sld/size
redrag
]
]
update: func [/text txt] [
if text [self/text: ar/text: txt]
ar/user-data: none
ar/line-list: none
sld/data: 0
ar/para/scroll: 0x0
redrag
show [ar sld]
]
append init [
self/init: []
para: make para []
pane: reduce [
ar: make-face/size/offset self size - 16x0 0x0
sld: make-face/size/offset/spec
either find styles 'scroller ['scroller] ['slider] 16x0 + (size * 0x1) ar/size * 1x0 [
action: func [face action] [scroll-para ar face]
effect: [gradient 200.200.200 230.230.230]
]
]
feel: make ar/feel [
old-e: :engage
detect: func [f e] [if e/type = 'down [view*/focal-face: ar/parent-face] e]
engage: func [face act event] [
either find [scroll-line scroll-page] act [
sld/data: min 1 max 0 sld/data + min 1
(either act = 'scroll-line [ar/font/size] [second page-size])
* (second event/offset) / second (size-text ar)
scroll-para ar sld
show sld
] [
view*/caret: either ar/user-data [ar/user-data] [ar/text]
view*/focal-face: ar
old-e ar act event
if view*/focal-face = ar [
ar/user-data: view*/caret
sld/data: (abs second caret-to-offset ar ar/text) / max 1 (second size-text ar) - (second page-size)
redrag
show sld
view*/focal-face: ar/parent-face
]
]
]
]
ar/feel: none
flags: exclude flags [font para]
image: edge: effect: none
update
]
]
]
port2ob: func [port [port!] /local x x2 nuovalinea before err line h value tmp tmp2 new] [
tmp: port/state/inbuffer
tmp2: port/state/outbuffer
port/state/inbuffer: port/state/outbuffer: none
x: mold port
port/state/inbuffer: tmp
port/state/outbuffer: tmp2
while [error? err: try [load x]] [
xl: parse/all x "^/"
err: disarm err
parse/all err/near ["(line " thru ") " copy line to end]
parse line [copy before thru ": " copy value to end]
either value [
nuovalinea: rejoin [before {"} "*** CHANGED WAS: " to-string value {"}]
x2: find x line
remove/part x2 length? line
insert x2 nuovalinea
] [make error! "can't list this port"]
]
parse/all x [
any [
set-word! h: " unset" (h: change/part h {"*** CHANGED WAS: unset"} 6) :h
| h: "make object! [...]" (h: change/part h "self" 18) :h
| skip
]
]
new: do x
new/state/inbuffer: either string? port/state/inbuffer [form port/state/inbuffer] [port/state/inbuffer]
new/state/outbuffer: either string? port/state/outbuffer [form port/state/outbuffer] [port/state/outbuffer]
new
]
get-item: func [item [object!] name [string!] /local ob x tmp] [
either item/expandblk [
if error? set/any 'tmp get-path/anyv/ignore first bind to-block head insert copy name "item/ob/" 'item [return :tmp]
get/any 'tmp
] [
ob: item/ob
if error? ob [ob: disarm ob]
either object? ob [
if error? set/any 'x get/any in ob first to-block name [x: disarm x]
get/any 'x
] [
either event? ob [
get-path/anyv/ignore head change back tail 'ob/fake first to-block name
] [
if error? set/any 'x pick ob to-integer name [x: disarm x]
get/any 'x
]
]
]
]
pathstr: func [item [object!]] [rejoin [item/pathto either item/pathto <> "" ["/"] [""] item/obname]]
intest: func [linea] [linea: parse linea none rejoin [linea/1 " " linea/2]]
clip: func [data /local ritorno] [
ritorno: copy ""
foreach item data [insert tail ritorno join item "^/"]
write clipboard:// ritorno
]
clipname: func [ctx /local value] [
value: either string? ctx/f-lista/picked/1 [value: first parse ctx/f-lista/picked/1 none] [""]
value: rejoin [pathstr ctx/f-lista/actual-item "/" value]
write clipboard:// value
]
alerta: func [testo face [object!] /local old] [
old: face/text
face/text: rejoin ["ATTENTION: " testo " !!"]
face/color: red
show face
face/color: pewter
face/text: old
]
change-sn: func [
{Change the first item displayed in a text-list and redrag the slider}
face whe /local len
] [
len: length? face/texts
if face/sn >= whe [face/sn: max 0 min len - face/lc whe - 1]
if face/sn <= (whe - face/lc) [face/sn: max 0 (whe - face/lc)]
face/sld/state: none
face/sld/data: face/sn / max 1 (len - face/lc)
face/sld/redrag min 1 face/lc / max 1 len
]
where?: func [
"Find the position of the first picked item if any"
lista [object!]
] [
either lista: find lista/texts lista/picked/1 [index? lista] [1]
]
move-to: func [lista [object!] where [integer! none!]] [
if where [
insert clear lista/picked pick lista/texts where
change-sn lista where
show lista
]
]
find-parse-list: func [lista [object!] value [string!] offset [integer!]] [
repeat x length? lista/texts [
if value = pick parse pick lista/texts x none offset [move-to lista x exit]
]
]
find-into-list: func [
"Find/match a text-list"
lista [object!] search [string!] pos [integer!]
] [
move-to lista pos: find-into at lista/texts pos + 1 search
pos
]
scroll-to: func [
"Scroll an area with slider and show them"
area slider text
] [
text: (caret-to-offset area text) - area/para/scroll
area/para/scroll: min 0x0 area/size / 2 - text
slider/data: (second text) / max 1 second size-text area
show [slider area]
]
find-area: func [
{Find text in an area-scroll, highlight, scroll and focus, return the new position}
area search [string!] pos "start position" case
] [
if not empty? search [
focus area/ar
pos: any [pos view*/caret head area/text]
if pos: refine-do [find pos search] [case] [
view*/highlight-start: view*/caret: pos
view*/highlight-end: pos: find/tail pos search
scroll-to area/ar area/sld pos
]
]
pos
]
viewcolors: has [out x n] [
out: copy []
parse second system/words [
any [
to tuple! x: (
if all [tuple? x/1 3 = length? x/1] [
insert insert tail out pick first system/words index? x x/1
]
) skip
]
]
sort/skip/compare out 2 [2]
n: 0
x: copy [across origin 5x5 space 1x1 styles my-styles style box box 75x55 font-size 11]
foreach [name color] out [
insert tail x compose [box as-is (rejoin [form name newline color]) (color)]
n: n + 1
if (n // 7) = 0 [insert tail x 'return]
]
insert tail x [return btn "Close" [munview/only x]]
mview/new x: layout x
]
refine: func [command [block!] refinement [block!] /with "Ignore refinement value" /local path] [
command: head change/only copy command path: to path! first command
foreach item refinement [
either block? item [
if any [with get first item] [
insert tail :path first item
insert tail command next item
]
] [
if any [with get item] [insert tail :path item]
]
]
command
]
refine-do: func [command [block!] refinement [block!]] [do refine command refinement]
do-key-face: func [event /local face] [
if face: find-key-face event/face event/key [
if get in face 'action [do-face face event/key]
return none
]
event
]
window-feel: make object! [
redraw: none
detect: func [face event /user-data] [
all [
object? user-data: event/face/user-data
find [key resize close scroll-line] event/type
in user-data event/type
return do refine/with [user-data event] reduce [event/type]
]
either event/type = 'key [do-key-face event] [event]
]
over: none
engage: none
]
mview: func [panel [object!] /new /offset xy /title text /options opts] [
either stopmode [
panel/feel: window-feel
panel/text: either title [text] [copy "AnaMonitor-Stop"]
panel/offset: either offset [xy] [view*/screen-face/size - panel/size / 2]
all [options panel/options: append any [panel/options copy []] opts]
show-popup panel
do-events
] [
refine-do [view/new panel] [[offset xy] [title text] [options opts]]
panel/feel: window-feel
any [new do-events]
]
]
munview: func [/only face] [
all [only not object? face exit]
if all [any [view*/pop-face stopmode] only face <> view*/pop-face] [exit]
either stopmode [hide-popup] [refine-do [unview] [[only face]]]
]
anahelp: func [ctx /local ar sld] [
munview/only ctx/helpface
ctx/helpface: layout [
origin 10x10 styles my-styles backcolor backcol
space 2
across
ar: area-scroll 600x370 - 16x0 203.204.205 203.204.205 help-string
bold font-name font-fixed wrap feel [engage: none]
keycode [f1 #"^["] [munview/only ctx/helpface]
return
tgl 120 basecol "License" "Help" [
either not value [ar/update/text help-string] [
header/license: any [
header/license
all [
any [
all [exists? %gpl.txt read %gpl.txt]
all [exists-thru? http://www.rebol.it/~romano/gpl.txt read-thru http://www.rebol.it/~romano/gpl.txt]
request-download http://www.rebol.it/~romano/gpl.txt
all [exists-thru? http://www.gnu.org/licenses/gpl.txt read-thru http://www.gnu.org/licenses/gpl.txt]
request-download http://www.gnu.org/licenses/gpl.txt
header/rights
]
]
]
ar/update/text either none? header/license [header/rights] [to string! header/license]
]
focus ar
]
do [focus ar]
]
mview/new/offset ctx/helpface ctx/ly/offset + 13x25
]
my-choose: func [texts f panel offset size ali /local old old-e] [
size: size - 0x4
old: get in svvf/choice-iterator 'engage
svvf/choice-iterator/engage: func [face act event] [
either event/type = 'down [
either all [face/selected face/selectable] [act: face/pane-parent hide-popup do-face face act] [hide-popup]
svvf/choice-iterator/engage: :old
] [show face]
]
offset: max 0x0 min offset panel/size - (size * 1x0) - (size * 0x1 * length? texts)
old-e: svv/choice-face/edge
svv/choice-face/edge: make panel/edge [effect: 'bevel size: 1x1]
choose/window/offset/style texts :f panel offset
make-face/size/spec/clone 'button size compose/deep [
colors: [(basecol) (orange - 20.20.20)]
font: make font [shadow: none align: (to-lit-word ali) size: 11]
para: make para [wrap?: false]
edge: none
]
svv/choice-face/edge: old-e
]
preferences: func [ctx /local sv useprefs prefs ly-pref-b h] [
useprefs: has [ly-old actual-item] [
basecol: prefs/base-color
backcol: prefs/back-color
ly-old: ctx/ly
actual-item: ctx/f-lista/actual-item
ctx/make-ly
ctx/f-lista/actual-item: actual-item
ctx/refresh
munview/only ly-old
mview/new/options/offset/title ctx/ly 'resize ly-old/offset ctx/title
munview/only ctx/ly-pref
]
prefs: ctx/prefs
sv: make prefs []
ly-pref-b: [
styles my-styles
backcolor backcol
across
check prefs/dbcl [prefs/dbcl: value] h4 "Double-click" return
check prefs/novalue [prefs/novalue: value] h4 "Show values of words" return
check prefs/nounset [prefs/nounset: value] h4 "Hide unset" return
check prefs/sort [prefs/sort: value] h4 "Sort list by"
h: at
h4 45 white backcol middle center pewter prefs/sortby [
my-choose
["Name" "Type"]
func [f b] [face/text: prefs/sortby: copy f/text]
ctx/ly-pref
h + 0x18
45x20
'center
]
return
check prefs/expandblk [prefs/expandblk: value] h4 "Expand nested blocks" return
h4 150 "Indent expanded blocks:"
field 40x21 form prefs/ind [
error? try [prefs/ind: min 12 max 0 to-integer face/text]
face/text: form prefs/ind show face
]
return
h4 150 "List font size:"
field 40x21 form prefs/fontsize [
error? try [prefs/fontsize: max 4 to-integer face/text]
face/text: form prefs/fontsize show face
]
return
h4 "When click on func:"
text "view" pad -4x2
check found? find prefs/on-function 'view [alter prefs/on-function 'view]
pad 0x-2 text "list" pad -4x2
check found? find prefs/on-function 'list [alter prefs/on-function 'list]
return
h4 "Back color" pad 0x-4
box backcol 25x25 edge [size: 1x1 color: black effect: none] [
if value: request-color/color face/color [
face/color: prefs/back-color: value
]
]
pad 14x4 h4 "Base color" pad 0x-4
box basecol 25x25 edge [size: 1x1 color: black effect: none] [
if value: request-color/color face/color [
face/color: prefs/base-color: value
]
]
return
pad 0x10
btn 50 "Save" [save ctx/fileprefs third prefs useprefs]
btn 50 "Use" [useprefs]
btn 50 "Cancel" #"^[" [ctx/prefs: sv munview/only ctx/ly-pref]
]
munview/only ctx/ly-pref
ctx/ly-pref: center-face/with layout ly-pref-b ctx/ly
mview/new/title ctx/ly-pref "Preferences"
]
help-string: rejoin [
header/title join " by " header/author newline
"Version: " header/version " " header/date newline
"Report bugs and wish to : " header/email newline
header/copyright newline
{
Anamonitor can be started with:
^-do %anamonitor.r
or
^-do/args %anamonitor.r system/view
or you can put in user.r
^-do/args %anamonitor.r false ;to not show the window
and then you can use one of:
^-monitor
^-^-to list the system object
^-monitor <word/path>
^-^-to list <word/path> (object/block/function/port)
^-mon <arg>
^-^-to list the evaluated <arg> (object/block/function/port)
^-stop <arg>
^-^-to list the evaluated <arg> (object/block/function/port)
^-^-Stop works in Modal Mode, so can be called inside
^-^-the action of a face to stop event handling until Anamonitor
^-^-window is closed (esc key)
^-^-(Modal Mode is also activated when an user pop-face is displayed)
^-^-^-Buttons and Menu
^-* = menu with standard object
^-! = menu for the listed object
^-Menu = global menu
^-right-click = popup menu for the selected item
^-< = left = go back in the history
^-> = right = go forward in the history
^-Pr/Vi = F4 = ^^P = probe or view the block/function/face...
^-exe = F2 = ^^E = edit and execute a command
^-new = open a new window (right-click open a new shell)
^-prefs = F8 = open preferences window
^-expand = ^^B = expand nested blocks (and refresh)
^-unset = ^^U = hide the unset values (and refresh)
^-sort = ^^S = sort the list (and refresh)
^-help = F1 = open the help window
^-find references = find references to/thru item
^-find references (func) = search also in func body
^-ctrl-t = tile windows
^-^-^-^-Others keys
^-F9 ^^R = refresh the list
^-^^C = copy whole list to the clipboard
^-^^X = copy selected item's path to the clipboard
^-up down = move up/down
^-page-down page-up = move one page up/down
^-home end = start or end of list
^-space return = list the selected item
^-esc = close the window (in stop mode also the main window)
^-shift-tab = cycle window (not available in stopmode)
^-click item = list or view the item
^-right-click item = open a popup menu for the item
^-^-^-^-Notes
^-port! and event! are listed with a trick
^-error! are listed disarmed
^-Modal (awake-event) system is patched to correct some bugs.
^-Win-offset? is patched to correct some bugs.
^-^-^-^-Abbreviations used in names
^-get() = get a word
^-getp() = get a path
^-fh() = function header (ex. third :source)
^-fb() = function body (ex. second :source)
^-fl() = function locals (ex. first :source)
^-hd() = head of block
^-ctx() = context of a word (show only standard loaded words)
^-^-^-^-Other utilities
^-Find-ref is a function to find references to a given value, use
^-^-help find-ref
^-from the console. Es.
^-
^-^-find-ref/body system/view
^-
^-^-^-^-Examples
^-do/args %anamonitor false
^-view layout ly: [
^-^-button "Stop" [
^-^-^-stop [ly face value]
^-^-]
^-^-button "Mon" [
^-^-^-mon [ly face value]
^-^-]
^-]
}
]
cb: [
itemob: context [ob: trueob: obname: truename: pathto: type: sorted: sortby: nounset: refresh: listall: expandblk: engage-cases: none whe: 1 listanomi: copy []]
ly: ly-exe: ly-pref: helpface: subface:
f-lista: f-text: f-intest: f-sort: f-unset: f-panel: f-expand:
h: none
search: ""
case: false
sf-off: 40x40
linelen: 200
cntype: 10 cnname: 21 cnblock: 4 cnblock-expanded: 14
histem: copy []
fileprefs: system/script/path/anampref.r
prefs: context [
dbcl: true
sort: false
fontname: font-fixed
fontsize: 12
wsize: 630x435
woffset: 50x50
nounset: false
sortby: "Name"
novalue: false
expandblk: true
ind: 4
on-function: [list view]
base-color: navy
back-color: pewter
shortcut: [
"Words" "system/words"
"System" "system"
"Options" "system/options"
"Script" "system/script"
"User" "system/user"
"Screen" "system/view/screen-face"
"Windows" "system/view/screen-face/pane"
"View" "system/view"
"Vid" "svv"
"Vid Colors" "svv/vid-colors"
"Vid Feel" "svvf"
"Vid Styles" "svv/vid-styles"
"Header" "header-rules"
"Net-utils" "net-utils"
"Mail-list-rules" "mail-list-rules"
]
]
wsize: prefs/wsize
sfsize: prefs/wsize - 25x25
ly-exesize: prefs/wsize - 100x150
listable: copy [
object! 'oblist
port! 'portlist
block! 'blklist
paren! 'blklist
hash! 'blklist
list! 'blklist
event! 'evlist
function! 'none
action! 'none
op! 'none
native! 'none
]
listable?: func [x [any-type!]] [find listable type?/word get/any 'x]
listall: func [item [object!] /local x] [
if x: select listable to-word mold item/type [
item/listanomi: copy []
item/sorted: item/nounset: item/expandblk: false
if x: do x item [item/listall: copy item/listanomi]
return x
]
]
portlist: func [item /local attrs tipo altro] [
if not port? item/ob [item/ob: item/ob/self]
if error? try [item/ob: port2ob attrs: item/ob] [
alerta "Can't list this port" f-intest
viewface/fixed pathstr item rejoin ["port " mold item/ob]
return false
]
item/ob/self: attrs
item/tipo: 'port!
attrs: next second item/ob
foreach el next first item/ob [
tipo: type? first attrs
altro: blobval first attrs
insert tail item/listanomi rejoin [lef el cnname " " lef tipo cntype " : " altro]
attrs: next attrs
]
true
]
oblist: func [item /local attrs tipo altro] [
attrs: second item/ob
foreach el first item/ob [
tipo: type? first attrs
altro: blobval first attrs
insert tail item/listanomi rejoin [lef el cnname " " lef tipo cntype " : " altro]
attrs: next attrs
]
true
]
evlist: func [item /local attrs tipo altro] [
evfield: [item/ob/type item/ob/time item/ob/face item/ob/offset item/ob/key item/ob/control item/ob/shift item/ob/double-click]
attrs: reduce evfield
foreach el evfield [
tipo: type? first attrs
altro: either unset? first attrs ["unset"] [either tipo <> error! [blobval first attrs] [clickme]]
insert tail item/listanomi rejoin [lef last :el cnname " " lef tipo cntype " : " altro]
attrs: next attrs
]
true
]
expand-block: func [
blk [block! paren! hash! list!]
name [string! none!]
dest [block! none!]
ind [string! none!]
/history hist [block! none!]
/local altro el save el-name s-index
] [
save: does [
insert/only tail dest rejoin [
lef el-name cnblock-expanded " " lef type-any?/word el cntype ": " ind altro
]
]
dest: any [dest copy []]
name: any [name copy ""]
ind: any [ind copy ""]
hist: head any [hist copy []]
while [find/only hist :blk] [
if same? head :blk head first hist [
el-name: join name 1
el: :blk
altro: "... (reflexion)"
save
return dest
]
hist: next hist
]
insert/only tail hist :blk
if error? try [s-index: subtract index? :blk 1] [
el-name: join name 1
el: :blk
altro: out-range
return dest
]
while [not tail? :blk] [
error? set/any 'el first :blk
el-name: join name subtract index? :blk s-index
either find [block! paren! hash! list!] type-any?/word el [
either error? try [tail? :el] [
altro: rejoin [either paren! = type-any? el [out-range] ["[out-of-range]"]]
save
] [
altro: rejoin [either paren! = type-any? el ["("] ["["]]
save
expand-block/history :el join el-name "/" dest join ind head insert/dup copy "" " " prefs/ind hist
change altro either paren! = type-any? el [")"] ["]"]
save
]
] [
altro: either error? try [
set/any 'altro get/any 'el
] [copy clickme] [copy blobval get/any 'altro]
save
]
blk: next :blk
]
dest
]
blklist: func [item /local x] [
if error? try [if 0 = length? item/ob [return false]] [return false]
either any [all [prefs/expandblk item/tipo <> 'references] item/tipo = 'funcbody item/tipo = 'funcheader] [
item/listanomi: expand-block item/ob none none none
item/expandblk: true
] [
x: 0
foreach el item/ob [
x: x + 1
insert tail item/listanomi rejoin [
rig x cnblock " " lef type-any?/word el cntype ": " blobval get/any 'el
]
]
]
true
]
face?: func [x [any-type!]] [
all [
object? :x
empty? exclude first system/words/face first x
value? in x 'type
x/type = 'face
]
]
probable: [block! funcbody funcheader funclocals]
viewprobe: func [item] [
if error? try [
either find probable item/tipo [
either find [funcbody funcheader funclocals] item/tipo [
viewface/fixed pathstr item rejoin [
"func " mold third get-path 'item/trueob mold second get-path 'item/trueob
]
] [viewface/fixed pathstr item mold item/ob]
] [if face? item/ob [faceview item/ob pathstr item]]
] [alerta "Error while probing" f-intest]
]
viewable: copy [
function! native! action! op! 'funcview
string! email! tag! issue! 'stringview
binary! 'binaryview
bitset! 'bitsetview
image! 'imageview
tuple! 'tupleview
pair! 'pairview
url! file! 'fileurlview
]
viewable?: func [x [word!]] [if parse viewable [to x to lit-word! set x to end] [x]]
viewall: func [el pname [string!] /local x] [
either x: viewable? type?/word :el [do x :el pname] [
either face? :el [faceview :el pname] [none]
]
]
face-start: does [
if subface [
sf-off: subface/offset
if any [not stopmode view*/pop-face = subface] [munview/only subface]
subface: none
]
]
viewface: func [
name [string!] text-data [string!] /fixed /nowrap /binary
/local h pos search xf sld ar case
] [
case: false
face-start
subface: layout [
origin 10x10 styles my-styles backcolor backcol
size sfsize space 2
across
btn "Copy" [write clipboard:// ar/data]
btn "Wrap" "^^W" #"^W" [
ar/para/wrap?: ar/para/wrap? xor true
ar/update
]
btn "Font" "^^F" #"^F" [
ar/font/name: either ar/font/name = font-fixed [font-sans-serif] [font-fixed]
ar/update
]
btn "Bin" "^^B" #"^B" [
ar/update/text either find ar/user-data 'binary [
remove find ar/user-data 'binary
to-string load ar/text
] [
append ar/user-data 'binary
mold/only to-binary ar/text
]
]
btn "Find" "f3" keycode [f3 #"^S"] [
search: either all [view*/highlight-start view*/highlight-end] [
copy/part view*/highlight-start view*/highlight-end
] [""]
h: false
inform layout [
styles my-styles
backcolor backcol
across
check case [case: face/data] h4 "Case" return
xf: field as-is search [search: value h: true hide-popup] return
btn 50 "OK" [search: xf/text h: true hide-popup]
btn 50 "Cancel" [hide-popup]
do [focus xf]
]
focus ar
if h [pos: find-area ar search pos case]
]
btn "Next" "f4" keycode [f4 #"^N"] [
pos: find-area ar search pos case
]
btn "Tile" "^^t" keycode [#"^T"] [tile]
btn "Close" escape [munview/only subface]
return
h: at
ar: area-scroll sfsize - h - 10x10 snow snow
para [wrap?: either nowrap [false] [true]]
font [size: prefs/fontsize name: either fixed [font-fixed] [font-sans-serif]]
text-data
user-data clear []
]
if binary [append ar/user-data 'binary]
subface/user-data: make object! [
resize: :resize-subface
area: :ar
min-size: window-mins/subface
key: func [event /local face] [
if none? either all [event/key = #"^-" event/shift] [
next-window event/face
] [do-key-face event] [return none]
event
]
]
focus ar
mview/new/offset/title/options subface sf-off name 'resize
]
funcview: func [f name /local ritorno] [
ritorno: rejoin [name ": "]
if function? :f [insert tail ritorno "func "]
insert tail ritorno mold third :f
if function? :f [insert tail ritorno mold second :f]
viewface/fixed name ritorno
]
stringview: func [el name] [viewface rejoin [name " - " length? el] form el]
binaryview: func [el name] [viewface/binary/fixed rejoin [name " - " length? el] form el]
helpdata: none
helpview: func [el name /local out __|_*__|_ data safe file] [
file: http://www.rebol.com/view/docs/ref-data.r
out: copy ""
safe: reduce [:prin :print]
prin: func [v] [insert tail out reform v ()]
print: func [v] [insert insert tail out reform v #"^/" ()]
__|_*__|_: :el
help __|_*__|_
set [prin print] safe
replace/all out "__|_*__|_" last parse/all name "/"
any [
helpdata
not connected?
all [exists-thru? file help2data: to-block read-thru file]
help2data: to-block request-download file
]
if all [
help2data
data: select help2data to-block last parse/all name "/"
] [
append out rejoin ["^/-------------" data/3 "-------------^/See also: " data/2 "^/-------------^/From " mold find/tail file "://" " - Copyright 2003 REBOL Technologies"]
]
viewface/fixed name out
]
fileurlview: func [el name /local tmp] [
viewface/fixed name rejoin [
"Form : " {"} form :el {"}
"^/^/Mold : " {"} mold/only :el {"}
"^/^/Binary : " to binary! :el
either url? :el [join "^/^/Decode : " mold/only decode-url :el] [join "^/^/Split : " either error? try [tmp: mold/only split-path :el] ["Invalid file"] [tmp]]
]
]
bitsetview: func [el name] [
viewface/fixed name rejoin [
el
"^/^/" charset-analyzer el
"^/= make bitset! [^/" charset-to-char el "]^/"
"^/= complement make bitset! [^/" charset-to-char complement el "]^/"
]
]
pairview: func [el name] [
if not any [
el/x <= 0 el/y <= 0
el/x > view*/screen-face/size/x
el/y > view*/screen-face/size/y
] [
face-start
subface: layout [
origin 10x10 styles my-styles backcolor backcol
h4 font-size prefs/fontsize rejoin [name " : " :el]
box :el yellow
key #"^[" [munview/only subface]
]
mview/new/offset/title subface sf-off "Pair"
]
]
tupleview: func [el name /local tmp] [
if 3 = length? el [
face-start
if tmp: find second system/words el [tmp: pick first system/words index? tmp]
subface: layout [
origin 10x10 styles my-styles backcolor backcol
h4 font-size prefs/fontsize reform [name ":" :el either tmp [rejoin ["(" tmp ")"]] [""]]
box 90x90 edge [color: coal size: 2x2] :el
key #"^[" [munview/only subface]
]
mview/new/offset/title subface sf-off "Tuple"
]
]
imageview: func [el name] [
face-start
subface: layout [
origin 10x10 styles my-styles backcolor backcol
h4 font-size prefs/fontsize name
box :el/size + 2x2 edge [size: 1x1] effect none :el
key #"^[" [munview/only subface]
]
mview/new/offset/title subface sf-off "Image"
]
faceview: func [el name] [
if all [face? :el el/size el/size <> 0x0] [
if image? el: to-image :el [imageview :el join "Image of face: " name]
]
]
if-error: func [try-blk [block!] error-blk [block!] /local x] [
either error? set/any 'x try try-blk error-blk [:x]
]
blobval: func [x [any-type!] /nr /local tmp tmp2 x1 x2 code get-type] [
code: [
copy/part rejoin [
lef mold :x 25
" ["
context? :x
either not undefined? :x [
rejoin [
" - "
do get-type
either any [not prefs/novalue nr not value? :x] [""] [
join " : " blobval/nr get/any 'tmp
]
]
] [""]
"]"
] linelen
]
switch test-value get/any 'x [
-2 [return "unset"]
-1 [return "(out-of-range)"]
]
x1: [set 'tmp2 rejoin ["[" length? :x " " index? :x "/" length? head :x "]"]]
x2: [set 'tmp2 copy/part trim/lines mold :x linelen]
switch-m/default type?/word :x [
block! hash! list! [do x1]
object! [copy/part rejoin ["[" length? first :x "] " mold first :x] linelen]
port! error! [clickme]
function! action! native! op! [copy/part trim/lines mold third :x linelen]
word! lit-word! set-word! get-word! refinement! [
get-type: [type? set/any 'tmp get/any :x]
do code
]
path! lit-path! set-path! [
get-type: [if-error [type? set/any 'tmp get-path/anyv/ignore :x] ["??"]]
do code
]
string! url! file! binary! tag! email! issue! [
copy/part rejoin [do x1 " " do x2] linelen
]
] [do x2]
]
changelista: func [item /local tmp offsort x y] [
if not find [funcbody] item/tipo [
if prefs/nounset <> item/nounset [
item/listanomi: either prefs/nounset [
while [not tail? item/listanomi] [
item/listanomi: either equal? second parse first item/listanomi " " "unset" [
remove item/listanomi
] [next item/listanomi]
]
head item/listanomi
] [item/listall]
item/nounset: prefs/nounset
item/whe: 1
]
if all [
not all [block? item/ob item/expandblk prefs/sortby = "Name"]
any [prefs/sort <> item/sorted prefs/sortby <> item/sortby]
] [
offsort: either select reduce [block! hash! list!] item/type [
offsort: either item/expandblk [cnblock-expanded] [cnblock]
select reduce ["Name" 0 "Type" offsort + 2 "Value" offsort + 2 + cntype] prefs/sortby
] [
select reduce ["Name" 0 "Type" cnname + 1 "Value" cnname + 1 + cntype] prefs/sortby
]
either prefs/sort [
sort/compare item/listanomi func [a b] [lesser? skip a offsort skip b offsort]
] [item/listanomi: item/listall]
item/sorted: prefs/sort
item/sortby: prefs/sortby
]
]
item/whe: 1
if item/refresh [
remove find back tail y: copy item/refresh "/"
x: item/listanomi
while [not tail? x] [
if find/match first x y [item/whe: index? x break]
x: next x
]
item/refresh: none
]
f-intest/text: rejoin [
index? histem "/" length? head histem " - " pathstr item " (" item/type ")"
]
f-lista/actual-item: item
f-lista/texts: f-lista/lines: f-lista/data: item/listanomi
f-lista/picked: reduce [pick f-lista/texts item/whe]
change-sn f-lista item/whe
show [f-intest f-lista]
]
selec-alt: func [offset new /menu /local item vc ctx newp x x-word blk tmp append-vc func-sel] [
func-sel: func [tipo [word!]] [
either menu [
if item/tipo <> tipo [
newlist/parent-path item/truename :x item tipo item/pathto
]
] [newlist/parent-path new :x item tipo pathstr item]
]
blk: [
"List In New Window" [
if error? :x [x: disarm :x]
error? try append/only copy either stopmode [
[system/words/stop]
] [
[system/words/monitor]
] either listable? :x [:x] [compose [(:x)]]
]
"View Rebol Help" [helpview :x form either x-word [x-word] [new]]
"Probe Block" [either menu [viewprobe item] [viewface/fixed newp mold :x]]
"Probe From Head" [viewface/fixed newp mold head :x]
"List From Head" [newlist new head :x item 'blockhead]
"Mold" [viewface/fixed newp mold :x]
"View From Head" [viewall head :x newp]
"Mold From Head" [viewface/fixed newp mold head :x]
"View Face" [faceview :x newp]
"List As Style" [newlist newp dump-as-style :x none 'none]
"View As Style" [viewface/fixed newp mold/only dump-as-style :x]
"View Source" [viewall :x newp]
"List Body" [func-sel 'funcbody]
"List Third" [func-sel 'funcheader]
"List First" [func-sel 'funclocals]
"Browse" [browse :x]
"Edit File/Show Dir" [
either exists? :x [
either dir? :x [
use [dir] [dir: what-dir change-dir :x request-file change-dir dir]
] [try [editor :x]]
] [alerta "Cannot find the file/dir" f-intest]
]
"Find references" [
alerta "wait....." f-intest
viewface/fixed join "references to/thru " newp rejoin/with find-ref/result/exclude :x [self ly] newline
show f-intest
]
"Find references (func)" [
alerta "wait....." f-intest
viewface/fixed join "references to/thru " newp rejoin/with find-ref/body/result/exclude :x [self ly] newline
show f-intest
]
]
append-vc: func [str] [
foreach str str [if str: find blk str [insert tail vc copy/part str 2]]
]
item: first histem
if either menu [
x: item/ob
if tmp: get in item 'trueob [x: :tmp]
new: item/obname
newp: pathstr item
] [
new: first parse new none
newp: does [rejoin [pathstr item "/" new]]
if 0 > test-value set/any 'x get-item item new [return]
all [
not unset? set/any 'x get-item item new
any [tmp: error? :x not error? try [tmp: not equal? :x item/ob]]
found? tmp
]
] [
vc: copy []
append-vc ["List In New Window"]
any [
if all [
any [any-word? :x any-path? :x]
not equal? "Undefined" ctx: context? :x
] [
x-word: :x
append vc reduce [
rejoin ["List " ctx " Context"] [
if any-path? :x-word [x-word: first :x-word]
either ctx = "Global" [
newlist "system/words" system/words none 'object!
find-parse-list f-lista form :x-word 1
] [
use [ctx selfc] [
ctx: v-c :x-word
either all [
selfc: find ctx 'self
selfc: first selfc
object? set/any 'selfc get/any selfc
same? :x-word inall selfc :x-word
not same? selfc item/ob
] [
newlist new selfc item 'objectcontext
find-parse-list f-lista form :x-word 1
] [
if not equal-bc? ctx item/ob [
newlist new ctx item 'blockcontext
find-parse-list f-lista join "'" form :x-word 4
]
]
]
]
]
]
either value? :x [
new: rejoin [new "=" mold :x]
either not error? try [error? set/any 'x get-all :x] [
append-vc ["View Rebol Help"]
false
] [true]
] [true]
]
if find [block! paren! hash! list!] type?/word :x [
append-vc ["Find references" "Find references (func)" "Probe Block"]
any [head? :x append-vc ["Probe From Head" "List From Head"]]
all [menu append-vc ["Expand nested blocks"]]
]
if all [any-string? :x not error? try [index? :x]] [
append-vc ["Mold" "Find references" "Find references (func)"]
any [head? :x append-vc ["View From Head" "Mold From Head"]]
if url? :x [append-vc ["Browse"]]
if file? :x [append-vc ["Edit File/Show Dir" "Browse"]]
]
if face? :x [append-vc ["Find references" "Find references (func)" "View Face" "List As Style" "View As Style"]]
if any-function? :x [
if function? :x [append-vc ["Find references" "Find references (func)" "View Source" "List Body"]]
append-vc ["List First" "List Third" "View Third" "View Rebol Help"]
]
if find [object! port! struct!] type?/word :x [
append-vc ["Find references" "Find references (func)"]
]
]
my-choose extract vc 2 func [f b] [switch f/text vc] ly offset 140x22 'left
]
]
selec: func [value /local new newp tipo x item tmp] [
item: first histem
tipo: item/type
new: first parse value none
newp: does [rejoin [pathstr item "/" new]]
if 0 > test-value set/any 'x get-item item new [return]
if all [
not unset? set/any 'x get-item item new
any [tmp: error? :x not error? try [tmp: not equal? :x item/ob]]
tmp
] [
either all [any-word? :x value? :x] [
new: rejoin ["GET(" new "=" mold :x ")"]
if error? x: get :x [x: disarm :x]
] [
if all [
any-path? :x
not error? try [error? set/any 'tmp get-path/anyv/ignore :x]
] [
new: rejoin ["GETP(" new "=" mold :x ")"]
x: either error? :tmp [x: disarm :tmp] [:tmp]
]
]
if error? :x [x: disarm :x]
if any [error? try [equal? :x :item/ob]] [return]
any [
if any-function? :x [
either function? :x [
if find prefs/on-function 'list [newlist new :x item 'funcbody]
if find prefs/on-function 'view [viewall :x newp]
] [
if find prefs/on-function 'list [newlist new :x item 'funcheader]
if find prefs/on-function 'view [viewall :x newp]
]
true
]
if listable? :x [newlist new :x item type?/word :x]
if viewable? type?/word :x [viewall :x newp]
]
]
]
go-to: func [ind [integer!]] [
if all [not tail? ind: skip head histem (ind - 1) ind <> histem] [
histem/1/whe: where? f-lista
histem: ind
changelista histem/1
]
]
go-back: does [go-to -1 + index? histem]
go-forward: does [go-to 1 + index? histem]
refresh: has [item] [
item: f-lista/actual-item
item/whe: where? f-lista
item/refresh: pick item/listanomi item/whe
listall item
changelista item
item/refresh: none
]
newstart: func [value [string!] /local start] [
either any [
value = ""
all [
error? try [start: get-path to-path load value]
error? try [start: do value]
]
] [
alerta "Invalid Value!" f-intest
] [
any [restart value :start alerta "Invalid Type!" f-intest]
]
]
engage-tl: func [face action event /local len whe] [
if action = 'key [
len: length? face/texts
either not found? find face/texts face/picked/1 [
clear face/picked
insert/only tail face/picked pick face/texts whe: 1
] [
whe: index? find face/texts face/picked/1
whe: switch-m/default event/key [
up [max 1 whe - 1]
down [min len whe + 1]
home [1]
end [len]
page-up [max 1 whe - face/lc + 1]
page-down [min len whe + face/lc - 1]
right [go-forward -1]
left #"^[" [go-back -1]
] [switch-m/default event/key bind f-lista/actual-item/engage-cases 'face [whe]]
if whe <> -1 [
clear face/picked
face/picked: reduce [pick face/texts whe]
]
]
if whe <> -1 [change-sn face whe]
show face
eat/only [key]
]
]
engage-iter: func [f a e] [
switch a [
down [
if cnt > length? head lines [exit]
if not e/control [f/state: cnt clear picked]
alter picked f/text
if any [not prefs/dbcl e/double-click] [do :act slf f/text]
]
alt-down [
if cnt > length? head lines [exit]
if not e/control [f/state: cnt clear picked]
alter picked f/text
do :alt-act f-lista/offset + f/offset + e/offset - 10x10 f/text
]
up [f/state: none]
alt-up [f/state: none]
]
show pane
]
newlist: func [
name [string!]
start
parent
type2 [word!]
/parent-path pp [string!]
/select-item value
/local newitem
] [
newitem: make itemob [
truename: name
switch type2 [
funcbody [trueob: :start name: rejoin ["FB(" name ")"] start: second :start]
funcheader [trueob: :start name: rejoin ["FH(" name ")"] start: third :start]
funclocals [trueob: :start name: rejoin ["FL(" name ")"] start: first :start]
blockhead [name: rejoin ["HD(" name ")"]]
blockcontext [name: rejoin ["CTX(" name ")"]]
objectcontext [name: rejoin ["CTX(" name ")"]]
]
ob: :start
obname: copy name
pathto: either parent-path [copy pp] [either none? parent [copy ""] [pathstr parent]]
type: type? :start
tipo: either 'none = type2 [type?/word :start] [type2]
expandblk: false
engage-cases: [#"^M" #" " [selec face/picked/1 -1]]
refresh: value
]
either listall newitem [
if not empty? histem [histem/1/whe: where? f-lista]
clear next histem
histem: back insert next histem newitem
changelista newitem
true
] [
newitem: none
false
]
]
hist-list: func [face /local hist hista] [
hist: copy []
hista: back tail histem
while [not 25 <= length? hist] [
insert hist rejoin [rig index? hista 3 " - " pathstr first hista]
if head? hista [break]
hista: back hista
]
my-choose hist func [f] [
go-to to-integer first parse f/text " "
] ly f-intest/size * 0x1 + face/offset f-intest/size 'left
]
exe: has [value result command ly-exeoff ex err h f-console probe-result ld] [
probe-result: true
use [actual-item] [
actual-item: f-lista/actual-item/ob
ld: function [] [file] [
if file: request-file/only [if file: read file [f-console/update/text file show f-console]]
]
ex: func [] [
if all [command: f-console/ar/text not empty? command] [
if confine [
if not try-err [
error? set/any 'result do bind load/all command 'actual-item
] [
either value? 'result [
try-err either all [not probe-result listable? :result] [
[restart "exe-result" result]
] [
[print ["==" copy/part mold :result 200]]
]
] [print ""]
]
] [print ["** Error: invalid return/break/throw"]]
refresh
]
]
command: join "actual-item" either empty? f-lista/picked [""] [
join "/" first parse f-lista/picked/1 none
]
ly-exeoff: sf-off
if ly-exe [ly-exeoff: ly-exe/offset munview/only ly-exe]
ly-exe: layout [
origin 10x10 styles my-styles backcolor backcol
space 4x4 size ly-exesize
style btn btn 50
across
btn "Exe" "^^E F5" keycode [#"^E" f5] [ex]
btn "Upd" "^^U F9" keycode [#"^U" f9] [
actual-item: f-lista/actual-item/ob loop 1000000 []
]
btn "Load" "^^L" keycode [#"^L"] [ld]
tgl 50 basecol red "List" "Probe" probe-result [probe-result: value]
btn "Tile" "^^t" keycode [#"^T"] [tile]
btn "Close" "^^Q Esc" keycode [#"^Q" #"^["] [munview/only ly-exe focus f-lista]
return
text 480 as-is {- Actual-item is set to the listed object/block: click Upd or F9 or Ctrl-U to update it
- Click Exe or F5 or Ctlr-E to execute
- Esc to quit}
return
h: at
f-console: area-scroll ly-exesize - h - 10x10 snow white font-name font-fixed
font-size prefs/fontsize command []
]
deflag-face f-console/ar tabbed
ly-exe/user-data: make object! [
resize: :resize-ly-exe
console: :f-console
min-size: window-mins/ly-exe
key: func [event /local len face] [
if none? either all [event/key = #"^-" event/shift] [
next-window event/face
] [do-key-face event] [return none]
event
]
]
focus f-console
mview/new/offset/title/options ly-exe ly-exeoff "Command to execute" 'resize
]
]
resize-subface: func [event /local face] [
face: event/face
face/old-size: face/size
face/size: max face/size face/user-data/min-size
if face/old-size = face/size [
face/user-data/area/resize face/user-data/area/size + face/size - sfsize
sfsize: face/size
]
show face
]
resize-ly-exe: func [event /local face] [
face: event/face
face/old-size: face/size
face/size: max face/size face/user-data/min-size
if face/old-size = face/size [
face/user-data/console/resize face/user-data/console/size + face/size - ly-exesize
ly-exesize: face/size
]
show face
]
resize-ly: func [event /local face minsize delta] [
face: event/face
minsize: face/user-data/min-size
delta: face/size
face/size: max face/size minsize
if face/size = delta [
delta: face/size - wsize
cnname: to-integer cnname * face/size/x / wsize/x
wsize: face/size
f-intest/size/x: f-intest/size/x + delta/x
f-panel/offset/x: f-panel/offset/x + delta/x
f-lista/size: f-lista/size + delta
f-lista/pane/size: f-lista/pane/size + delta
f-lista/sub-area/size: f-lista/sub-area/size + delta
f-lista/iter/size/x: f-lista/iter/size/x + delta/x
f-lista/sld/offset/x: f-lista/sld/offset/x + delta/x
f-lista/sld/size/y: f-lista/sld/size/y + delta/y
f-lista/lc: to integer! f-lista/size/y / f-lista/sub-area/size/y
f-text/size/x: f-text/size/x + delta/x
refresh
]
show ly
]
next-window: func [face /local blk tmp] [
if all [not stopmode blk: find reduce [ly ly-exe subface] face] [
forever [
if tail? blk: next blk [blk: head blk]
if face = tmp: first blk [break]
if find view*/screen-face/pane tmp [
tmp/changes: 'activate
show tmp
break
]
]
]
none
]
tile: func [] [tile-face subface 'below tile-face ly-exe 'across]
tile-face: func [face [object! none!] mode] [
if face [
switch mode [
below [
face/offset: max 0x0 min view*/screen-face/size - 20x20 as-pair [
ly/offset/x - view*/resize-border/x
ly/offset/y + ly/size/y + view*/resize-border/y
]
face/size: max face/user-data/min-size as-pair [
ly/size/x
view*/screen-face/size/y - face/offset/y - view*/title-size/y - view*/resize-border/y - 32
]
]
across [
face/offset: max 0x0 min view*/screen-face/size - 20x20 as-pair [
ly/offset/x + ly/size/x + view*/resize-border/x
ly/offset/y - view*/title-size/y - view*/resize-border/y
]
face/size: max face/user-data/min-size as-pair [
view*/screen-face/size/x - face/offset/x - (2 * view*/resize-border/x)
ly/size/y
]
]
]
show face
]
]
lyb: copy/deep [
origin 10x10 styles my-styles backcolor backcol
size wsize
style myh4 h4 white no-wrap center
across
space 5x1
f-intest: h4 white backcol first wsize - 218 bold para [wrap?: false] "" [hist-list face]
f-panel: auto-panel [
origin 0x0
across
space 5x1
myh4 50 "Expand" basecol feel [engage: none]
f-expand: check #"^B" prefs/expandblk [
if char? value [face/data: face/data xor true show face]
prefs/expandblk: face/data refresh
]
myh4 40 "Unset" basecol feel [engage: none]
f-unset: check #"^U" prefs/nounset [
if char? value [face/data: face/data xor true show face]
prefs/nounset: face/data refresh
]
myh4 30 "Sort" [
my-choose ["None" "Name" "Type"] func [f b] [
prefs/sort: f-sort/data: either f/text = "None" [false] [
prefs/sortby: copy f/text true
]
f-sort/color: red show f-sort
refresh
f-sort/color: white show f-sort
] face/parent-face/parent-face face/parent-face/offset + face/offset + 0x20 45x20 'center
]
f-sort: check #"^S" prefs/sort [
if char? value [face/data: face/data xor true show face]
prefs/sort: face/data refresh
]
]
return
space 1
btn 12 "*" [
my-choose extract prefs/shortcut 2 func [f b] [
newstart form select prefs/shortcut f/text
] ly 0x1 * face/size + face/offset 100x20 'left
]
btn 12 "!" [selec-alt/menu face/offset + (0x1 * face/size) ""]
btn "Menu" [
my-choose extract com-list 3 func [f b] [
ana-exe f/text
] ly 0x1 * face/size + face/offset 200x20 'left
]
arrow left basecol white 24x24 [go-back]
arrow right basecol white 24x24 [go-forward]
btn "New" "F2 ^^w" keycode [f2 #"^W"] [ana-exe <new>] [ana-exe <console>]
btn "Fnd" keycode [f3 #"^F"] [
show f-intest
inform layout [
styles my-styles
backcolor backcol
across
check case [case: face/data] h4 "Case" return
face: field as-is search [h: true hide-popup] return
btn 50 "OK" [h: true hide-popup]
btn 50 "Cancel" [hide-popup]
do [focus face]
]
if h [any [find-into-list f-lista search: face/text 0 alerta "Not found" f-intest]]
]
btn "Nxt" keycode [f4 #"^N"] [
show f-intest
if all [search not empty? search] [
any [find-into-list f-lista search where? f-lista alerta "Not found" f-intest]
]
]
key #"^T" [tile]
btn "Exe" "F5 ^^E" keycode [f5 #"^E"] [ana-exe <execute>]
btn "Pr/Vi" "F6" keycode [f6 #"^P"] [ana-exe <probeview>]
btn "Pref" "F8" keycode [f8] [ana-exe <prefs>]
space 2
btn "Help" "F1" keycode [f1] [ana-exe <help>] [ana-exe <console>]
space 5
h: at f-text: field wsize/x - h/x - 10 copy "Name or command" [newstart value]
return
f-lista: text-list wsize - 20x56 black font-name font-fixed font-size prefs/fontsize
no-wrap data "" [selec value]
with [actual-item: none alt-act: func [offset value] [selec-alt offset value]]
do [
f-lista/feel: make f-lista/feel [engage: :engage-tl]
bind second :engage-iter in f-lista 'self
f-lista/iter/feel: make f-lista/iter/feel [engage: :engage-iter]
f-lista/sld/action: func [face value] append copy/deep second get in f-lista/sld 'action [eat]
f-lista/sld/effect: [gradient 200.200.200 230.230.230]
]
]
com-list: copy/deep [
"Refresh^-^-- Ctrl-R F9" <refresh> [refresh]
"Copy List^-^-- Ctrl-C" <copylist> [clip f-lista/data]
"Copy Item Path^-- Ctrl-X" <copyitem> [clipname self]
"Probe/View^-^-- Ctrl-P F4" <probeview> [viewprobe f-lista/actual-item]
"Execute^-^-- Ctrl-E" <execute> [exe]
"New Window^-^-- Ctrl-N F2" <new> [do reduce ['system/words/monitor f-lista/actual-item/ob]]
"New Console" <console> [launch ""]
"View Global Colors" <colors> [viewcolors]
"Toggle Expand^-- Ctrl-B" <expand> [do-face f-expand #"a"]
"Toggle Unset^-^-- Ctrl-U" <unset> [do-face f-unset #"a"]
"Toggle Sort^-^-- Ctrl-S" <sort> [do-face f-sort #"a"]
"Tile windows^-^-- Ctrl-T" <tile> [tile]
"Preferences^-^-- F8" <prefs> [Preferences self]
"Browse Dictionary" <dictio> [browse http://www.rebol.com/docs/dictionary.html]
"Browse Library" <library> [browse http://www.reboltech.com/library/library.html]
"Browse Docs" <docs> [browse http://www.rebol.com/docs.html]
"Help/About^-^-- F1" <help> [anahelp self]
]
ana-exe: func [command [string! tag!]] [switch-m command com-list]
title: does [
rejoin [
header/title " - " header/version
either header/beta ["-Beta"] [""]
either stopmode [" - StopMode"] [""]
either awnum <> 1 [join " - " awnum] [""]
]
]
restart: func [name [string!] start /select-item value /local type2] [
if error? :start [start: disarm :start]
refine-do [
newlist name :start none either any-function? :start [
pick [funcbody funcheader] function? :start
] ['none]
] [[select-item value]]
]
make-ly: function [] [] [
ly: layout lyb
ly/user-data: make object! [
lista: :f-lista
text: :f-text
resize: :resize-ly
min-size: window-mins/ly
scroll-line: func [event /local len] [
len: length? lista/texts
lista/sn: max 0 min len - lista/lc lista/sn + second event/offset
lista/sld/data: lista/sn / max 1 len - lista/lc
lista/sld/state: none
lista/sld/redrag lista/lc / max 1 len
show lista
none
]
key: func [event] [
if none? either all [event/key = #"^-" event/shift] [
next-window event/face
] [do-key-face event] [return none]
if view*/focal-face <> lista [
either view*/focal-face = text [
if event/key = #"^[" [focus lista return none]
] [focus lista]
]
event
]
]
]
awnum: set 'wnum wnum + 1
Monitor: func [
"Visual monitor of objects/blocks" 'start [any-type!]
/stop
/async
/select-item value
/name string [string!]
/local startname ev
] [
stopmode: stop
if not value? 'start [start: 'system]
name: either name [string] [either block? :start ["<block>"] [form :start]]
any [
if path? :start [set/any 'start get-path :start true]
if any-word? :start [
if error? set/any 'start get/any :start [start: disarm get/any :start]
true
]
]
if any [not value? 'start not listable? :start] [
print ["Invalid argument. Not one of:" extract listable 2]
exit
]
if exists? fileprefs [prefs: make prefs load/all fileprefs]
use [v] [
parse/all mold first system/words [
any [
to "ctx-" copy h to " " (
set/any 'v get/any load h
if all [
value? 'v
any [object? :v block? :v]
not find prefs/shortcut h
] [insert insert tail prefs/shortcut h h]
)
]
]
]
backcol: prefs/back-color
basecol: prefs/base-color
wsize: prefs/wsize
sfsize: prefs/wsize - 25x25
ly-exesize: prefs/wsize - 100x150
make-ly
if refine-do [restart name :start] [[select-item value]] [
focus f-lista
mview/new/options/offset/title ly 'resize prefs/woffset title
any [stopmode async do-events]
wnum: wnum - 1
none
]
]
]
cache: []
set 'Monitor func ["Visual monitor of objects/blocks" 'start [any-type!] /stop /local s-m] [
insert tail cache s-m: context cb
if view*/pop-face [stop = true]
any [value? 'start start: 'system]
refine-do [s-m/monitor :start] [stop]
remove back tail cache
none
]
set 'Mon func ["Monitor of objects/blocks" start] [monitor :start :start]
set 'Stop func ["Modal visual monitor of objects/blocks" start] [monitor/stop :start :start]
]
either get in system/script 'args [
monitor system/script/args
] [
if false <> system/script/args [monitor]
] |
