Index: openacs-4/packages/xotcl-core/xotcl-core.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v diff -u -r1.92.2.6 -r1.92.2.7 --- openacs-4/packages/xotcl-core/xotcl-core.info 23 Dec 2015 18:21:56 -0000 1.92.2.6 +++ openacs-4/packages/xotcl-core/xotcl-core.info 30 Dec 2015 18:09:13 -0000 1.92.2.7 @@ -10,7 +10,7 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) 2015-10-04 @@ -48,9 +48,9 @@ BSD-Style 2 - + - + Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v diff -u -r1.78.2.4 -r1.78.2.5 --- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 7 Dec 2015 16:58:07 -0000 1.78.2.4 +++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 30 Dec 2015 18:09:14 -0000 1.78.2.5 @@ -1,15 +1,26 @@ -## tell serializer to export methods, although these are methods of -# ::xotcl::Object if {$::tcl_version < 8.5 || ([regexp {8[.]5[.]([0-9]+)$} $::tcl_patchLevel _ minor] && $minor < 4) } { ns_log error "We require for this version of xotcl-core at least Tcl 8.5.4 (avail: Tcl $::tcl_patchLevel)" return } +if {[info exists ::xotcl_version] || ([info exists ::xotcl::version] && $::xotcl::version < 2.0)} { + ns_log error "We require for this version of xotcl-core at least XOTcl 2.0" + return +} package require xotcl::serializer +# +# Keep the initcmds of classes for documentaiton purposes. +# +::nsf::configure keepcmds 1 + +# +# Tell serializer to export methods, although these are methods of the +# base classes. +# ::Serializer exportMethods { ::xotcl::Object instproc log ::xotcl::Object instproc ds @@ -24,59 +35,20 @@ ::xotcl::Class instproc extend_slot } -if {$::xotcl::version < 1.5} { - # XOTcl 1.5 comes already with a predefined, more powerful - # implementation of contains. - - ::Serializer exportMethods { - ::xotcl::Object instproc contains - } - ::xotcl::Object instproc contains cmds { - my requireNamespace - namespace eval [self] $cmds - } - # XOTcl 1.5 or newer supports slots. Here we have to - # emulate slots up to a certain point - namespace eval ::xo { - ::xotcl::MetaSlot create ::xo::Attribute \ - -parameter { - {name "[namespace tail [::xotcl::self]]"} - {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"} - {multivalued false} - {required false} - default - type - spec - pretty_name - {pretty_plural ""} - {datatype "text"} - constraint_values - help_text - validator - } - } - - ::Serializer exportMethods { - ::xotcl::nonposArgs proc integer - ::xotcl::nonposArgs proc optional - } - -} else { - namespace eval ::xo { - # create xo::Attribute as a subclass of the slot ::xotcl::Attribute - ::xotcl::MetaSlot create ::xo::Attribute \ - -superclass ::xotcl::Attribute \ - -parameter { - spec - {required false} - pretty_name - {pretty_plural ""} - {datatype "text"} - constraint_values - help_text - validator - } - } +namespace eval ::xo { + # create xo::Attribute as a subclass of the slot ::xotcl::Attribute + ::xotcl::MetaSlot create ::xo::Attribute \ + -superclass ::xotcl::Attribute \ + -parameter { + spec + {required false} + pretty_name + {pretty_plural ""} + {datatype "text"} + constraint_values + help_text + validator + } } set ::xo::naviserver [expr {[ns_info name] eq "NaviServer"}] @@ -97,27 +69,28 @@ ::nx::Slot public alias set -frame object ::set ::nx::Slot public method exists {var} {::nsf::var::exists [self] $var} ::nx::Object public method serialize {} {::Serializer deepSerialize [self]} - ::nx::Object method set_instance_vars_defaults {} {:configure} ::nx::Object public method destroy_on_cleanup {} {set ::xo::cleanup([self]) [list [self] destroy]} ::nx::Object method qn {query_name} { return "dbqd.[:uplevel [list current class]]-[:uplevel [list current method]].$query_name" } - ::xotcl::Object instproc set_instance_vars_defaults {} {:configure} ::xotcl::Object proc setExitHandler {code} {::nsf::exithandler set $code} + ::xotcl::Object instproc set_instance_vars_defaults {} {:configure} ::Serializer exportMethods { ::nx::Object method serialize - ::nx::Object method set_instance_vars_defaults ::nx::Object method destroy_on_cleanup ::nx::Object method qn ::nx::Slot method istype ::nx::Slot method exists ::nx::Slot method set + ::nx::Object nsfproc ::nsf::debug::call + ::nx::Object nsfproc ::nsf::debug::exit } if {[nx::Class info methods -path "info superclasses"] eq ""} { - # map method names to improve robustness for earlier versions - # (should be transitional code). + # There is no "info superclasses" defined, it must be a beta + # release of nsf. Map method names to improve robustness for + # earlier versions (should be transitional code). array set ::xo::mapMethodNames { superclasses superclass subclasses subclass @@ -130,37 +103,12 @@ mixins mixins } } - -} else { - ::xotcl::Object instproc set_instance_vars_defaults {} { - set pcl [[my info class] info parameterclass] - $pcl searchDefaults [self] + proc ::nsf::debug::call {level objectInfo methodInfo arglist} { + ns_log Warning "DEBUG call($level) - $objectInfo $methodInfo $arglist" } - - # - # The XOTcl1_ParameterHandler is for forward compatibility in XOTcl1 - # to allow to load programs with xotcl2/nx value checkers in - # parameter declarations. The handler simply strips (ignores) - # xotcl2's parameter declarations. - # - namespace eval ::xo {} - ::xotcl::Class create ::xo::XOTcl1_ParameterHandler - ::xo::XOTcl1_ParameterHandler instproc __stripped_parameter {element} { - regexp {^([^:]+):} $element _ element - return $element + proc ::nsf::debug::exit {level objectInfo methodInfo usec} { + ns_log Warning "DEBUG exit($level) - $objectInfo $methodInfo $usec usec" } - ::xo::XOTcl1_ParameterHandler instproc parameter {list} { - set result {} - foreach element $list { - if {[llength $element] == 1} { - lappend result [my __stripped_parameter $element] - } else { - lappend result [concat [my __stripped_parameter $element] [lrange $element 1 end]] - } - } - next $result - } - ::xotcl::Class instmixin ::xo::XOTcl1_ParameterHandler } @@ -813,7 +761,7 @@ } "instproc" { if {"::xotcl::Object" in [$o info precedence]} {return [$o info instprocs {*}$args]} - return [$o info methods -type scripted {*}$args] + return [$o info methods -type scripted -callprotection all {*}$args] } "instcommand" { if {"::xotcl::Object" in [$o info precedence]} {return [$o info instcommands {*}$args]} @@ -823,13 +771,20 @@ if {"::xotcl::Object" in [$o info precedence]} {return [$o info instforward {*}$args]} return [$o info methods -type forwarder {*}$args] } + "instmethodtype" { + return [$o ::nsf::methods::class::info::method type {*}$args] + } + "methodtype" { + return [$o ::nsf::methods::object::info::method type {*}$args] + } "proc" { if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} return [$o info object methods -type scripted {*}$args] } "command" { - if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} - return [$o info object methods {*}$args] + #if {"::xotcl::Object" in [$o info precedence]} {return [$o info procs {*}$args]} + #return [$o info object methods {*}$args] + return [$o ::nsf::methods::object::info::methods {*}$args] } "forward" { if {"::xotcl::Object" in [$o info precedence]} {return [$o info forward {*}$args]} @@ -877,13 +832,34 @@ if {"::xotcl::Object" in $p} {return 1} return [nsf::is object $o] } + "isbaseclass" { + if {[info commands $o] eq ""} {return 0} + if {[catch {set p [$o info precedence]}]} {return 0} + return [expr {[lindex $p end] eq $o}] + } + "instmethodparameter" { + return [$o ::nsf::methods::class::info::method parameter {*}$args] + } + "methodparameter" { + return [$o ::nsf::methods::object::info::method parameter {*}$args] + } "instargs" { if {"::xotcl::Object" in [$o info precedence]} {return [$o info instargs {*}$args]} - return [$o info method args {*}$args] + set posargs {} + foreach m [$o info method args {*}$args] p [$o info method parameters {*}$args] { + if {[string range [lindex $p 0] 0 0] eq "-"} continue + lappend posargs $m + } + return $posargs } "args" { if {"::xotcl::Object" in [$o info precedence]} {return [$o info args {*}$args]} - return [$o info object method args {*}$args] + set posargs {} + foreach m [$o info object method args {*}$args] p [$o info object method parameters {*}$args] { + if {[lrange [string index $p 0] 0 0] eq "-"} continue + lappend posargs $m + } + return $posargs } "instargdefault" { if {"::xotcl::Object" in [$o info precedence]} { @@ -904,7 +880,7 @@ return [uplevel [list $o info default {*}$args]] } lassign $args method arg varName - foreach p [$o info object method parameter $method] { + foreach p [$o info object method parameters $method] { lassign $p name default if {$name eq $arg} { uplevel [list set $varName $default] Index: openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl,v diff -u -r1.7.2.3 -r1.7.2.4 --- openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 7 Dec 2015 16:58:07 -0000 1.7.2.3 +++ openacs-4/packages/xotcl-core/tcl/03-doc-procs.tcl 30 Dec 2015 18:09:14 -0000 1.7.2.4 @@ -19,175 +19,514 @@ ::xotcl::Class instproc ad_instproc ::xotcl::Class instproc ad_instforward ::xotcl::Object instproc ad_doc - ::xotcl::Object instproc __api_make_doc ::xotcl::Object instproc __api_make_forward_doc + ::nx::Class method init } -::Serializer exportObjects { - ::xotcl::api -} -::xotcl::Object create ::xotcl::api \ - -proc method_link {obj kind method} { - set kind [string trimright $kind s] - set proc_index [::xotcl::api proc_index "" $obj $kind $method] - if {[nsv_exists api_proc_doc $proc_index]} { - return "$method" +::nx::Object create ::xo::api { + + array set :methodLabel { + 1-instproc "method" + 1-proc "object method" + 0-instproc "instproc" + 0-proc "proc" + } + + # + # Support functions for the the OpenACS API browser + # + :public object method method_label { -kind:switch proc_spec } { + switch [llength $proc_spec] { + 1 {} + 3 {lassign $proc_spec obj methodType method} + 4 {lassign $proc_spec scope obj methodType method} + default { + ns_log notice "Unexpected format <$proc_spec> consists of [llength $proc_spec] parts" + } + } + if {[info exists method]} { + set isNx [::nsf::directdispatch $obj ::nsf::methods::object::info::hastype ::nx::Class] + if {$kind} { + return [set :methodLabel($isNx-$methodType)] } else { - if {[::xo::getObjectProperty $obj ${kind} $method] eq ""} { - return $methodC - } else { - return $method - } + return "$obj [set :methodLabel($isNx-$methodType)] $method" } - } \ - -proc isclass {scope obj} { - expr {$scope eq "" ? - [xo::getObjectProperty $obj isclass] : - [$scope do xo::getObjectProperty $obj isclass]} - } -proc isobject {scope obj} { - expr {$scope eq "" ? - [xo::getObjectProperty $obj isobject] : - [$scope do xo::getObjectProperty $obj isobject]} - } -proc scope {} { - if {[info exists ::xotcl::currentThread]} { - # we are in an xotcl thread; the body won't be accessible directly - return $::xotcl::currentThread - } + } + return $proc_spec + } + + :public object method debug_widget { proc_spec } { + # + # Return HTML code for a debug switch that lets an admin turn + # debugging of functions and methods on and off. This + # functionality is only allowed to site-wide admins + # + if {![acs_user::site_wide_admin_p] + || [info commands ::nsf::method::property] eq "" + || $::nsf::version < 2.1 + } { return "" + } - } -proc scope_from_object_reference {scope_var object_var} { - upvar $scope_var scope $object_var object - set scope "" - regexp {^(.+) do (.+)$} $object match scope object - - } -proc scope_from_proc_index {proc_index} { - set scope "" - regexp {^(.+) .+ (inst)?proc (.+)$} $proc_index match scope - return $scope - - } -proc inscope {scope args} { - expr {$scope eq "" ? [eval $args] : [$scope do {*}$args]} - - } -proc script_name {scope} { - #set kind [expr {[my istype ::xotcl::Class] ? "Class" : "Object"}] - #return "$scope$kind [self]" - set script [info script] - if {$script eq "" && [info exists ::xotcl::currentScript]} { - set script $::xotcl::currentScript + switch [llength $proc_spec] { + 1 {lassign [list "" ::nx::Object nsfproc $proc_spec] scope obj methodType method + if {![string match ::* $method]} {set method ::$method} } - set root_dir [acs_root_dir] - set root_length [string length $root_dir] - if { $root_dir eq [string range $script 0 $root_length-1]} { - set script [string range $script $root_length+1 end] + 3 {lassign $proc_spec obj methodType method; set scope ""} + 4 {lassign $proc_spec scope obj methodType method} + default { + ns_log notice "Unexpected format <$proc_spec> consists of [llength $proc_spec] parts" + return "" } - return $script + } + if {$methodType eq "proc"} { + set modifier "-per-object" + } elseif {$methodType in {instproc nsfproc}} { + set modifier "" + } else { + ns_log warning "unexpected method type <$methodType>" + set modifier "" + } + set debug_p [{*}$scope ::nsf::method::property $obj {*}$modifier $method debug] + + # + # Increment global form_id + # + set form_id "form-[incr ::__form_id]" + + # + # Add the JavaScript function only once, which will toggle the + # debug state in the background (template::add_script would add + # it multiple times). + # + if {$::__form_id eq "1"} { + # + # jquery is just needed for the used ajax call + # + template::head::add_javascript -src https://code.jquery.com/jquery-1.11.3.min.js - } -proc object_link {{-noimg:boolean off} scope obj} { - set link "" - if {$noimg} { - return "$link$obj" - } else { - return "$obj$link\[i\]" + template::add_script -script { + function ajax_submit(form) { + console.log(form); + $.ajax({ + type: "POST", + url: "/xotcl/admin/toggle-debug", + data: $(form).serialize(), + success: function(msg) {}, + error: function(){alert("failure");} + }); + }; } + } - } -proc object_url {{-show_source 0} {-show_methods 1} scope obj} { - set object [expr {$scope eq "" ? $obj : "$scope do $obj"}] - return [export_vars -base /xotcl/show-object {object show_source show_methods}] - } -proc object_index {scope obj} { - set kind [expr {[my isclass $scope $obj] ? "Class" : "Object"}] - return "$scope$kind $obj" + # + # Add the required js and CSS. We use here bootstrap + titatoggle. + # + template::head::add_css -href https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/css/bootstrap.min.css + template::head::add_javascript -src https://maxcdn.bootstrapcdn.com/bootstrap/3.3.6/js/bootstrap.min.js + template::head::add_css -href "/resources/xotcl-core/titatoggle/titatoggle-dist.css" + # + # Return an HTML snippet with a form and the computed form-ID + # + if {$debug_p} {set state checked} {set state ""} + set html [subst { +
+
+ +
+
+ }] + return $html + } - } -proc proc_index {scope obj instproc proc_name} { - if {$scope eq ""} { - return "$obj $instproc $proc_name" + :public object method method_link {obj kind method} { + set kind [string trimright $kind s] + set proc_index [::xo::api proc_index "" $obj $kind $method] + if {[nsv_exists api_proc_doc $proc_index]} { + return "$method" + } else { + if {[::xo::getObjectProperty $obj ${kind} $method] eq ""} { + return $methodC } else { - return "$scope $obj $instproc $proc_name" + return $method } + } + } - } -proc source_to_html {{-width 100} string} { - set lines [list] - foreach l [split $string \n] { - while {[string length $l] > $width} { - set pos [string last " \{" $l $width] - if {$pos>10} { + :public object method isclass {scope obj} { + expr {$scope eq "" ? + [xo::getObjectProperty $obj isclass] : + [$scope do xo::getObjectProperty $obj isclass]} + } + + :public object method isobject {scope obj} { + expr {$scope eq "" ? + [xo::getObjectProperty $obj isobject] : + [$scope do xo::getObjectProperty $obj isobject]} + } + + :public object method scope {} { + if {[info exists ::xotcl::currentThread]} { + # we are in an xotcl thread; the body won't be accessible directly + return $::xotcl::currentThread + } + return "" + } + + :public object method scope_from_object_reference {scope_var object_var} { + upvar $scope_var scope $object_var object + set scope "" + regexp {^(.+) do (.+)$} $object match scope object + } + + :public object method scope_from_proc_index {proc_index} { + set scope "" + regexp {^(.+) .+ (inst)?proc (.+)$} $proc_index match scope + return $scope + } + + :public object method inscope {scope args} { + expr {$scope eq "" ? [eval $args] : [$scope do {*}$args]} + } + + :public object method script_name {scope} { + set script [info script] + if {$script eq "" && [info exists ::xotcl::currentScript]} { + set script $::xotcl::currentScript + } + set root_dir [acs_root_dir] + set root_length [string length $root_dir] + if { $root_dir eq [string range $script 0 $root_length-1]} { + set script [string range $script $root_length+1 end] + } + return $script + } + + :public object method object_link {{-noimg:boolean off} scope obj} { + set link "" + if {$noimg} { + return "$link$obj" + } else { + return "$obj$link\[i\]" + } + } + + :public object method object_url {{-show_source 0} {-show_methods 1} scope obj} { + set object [expr {$scope eq "" ? $obj : "$scope do $obj"}] + return [export_vars -base /xotcl/show-object {object show_source show_methods}] + } + + :public object method object_index {scope obj} { + set kind [expr {[:isclass $scope $obj] ? "Class" : "Object"}] + return "$scope$kind $obj" + } + + :public object method proc_index {scope obj instproc proc_name} { + if {$scope eq ""} { + return "$obj $instproc $proc_name" + } else { + return "$scope $obj $instproc $proc_name" + } + } + + :public object method source_to_html {{-width 100} string} { + set lines [list] + foreach l [split $string \n] { + while {[string length $l] > $width} { + set pos [string last " \{" $l $width] + if {$pos>10} { + lappend lines "[string range $l 0 $pos-1] \\" + set l " [string range $l $pos end]" + } else { + # search for a match right of the target + set pos [string first " \{" $l $width] + if {$pos > 10} { lappend lines "[string range $l 0 $pos-1] \\" set l " [string range $l $pos end]" } else { - # search for a match right of the target - set pos [string first " \{" $l $width] - if {$pos>10} { + # last resort try to split around spaces + set pos [string last " " $l $width] + if {$pos > 10} { lappend lines "[string range $l 0 $pos-1] \\" set l " [string range $l $pos end]" } else { - # last resort try to split around spaces - set pos [string last " " $l $width] - if {$pos>10} { - lappend lines "[string range $l 0 $pos-1] \\" - set l " [string range $l $pos end]" - } else { - break - } + break } } } - lappend lines $l } - set string [join $lines \n] - set html [ns_quotehtml $string] - regsub -all {(\n[\t ]*)(\#[^\n]*)} $html \\1\\2 html - return "
$html
" + lappend lines $l } + set string [join $lines \n] + set html [ns_quotehtml $string] + regsub -all {(\n[\t ]*)(\#[^\n]*)} $html \\1\\2 html + return "
$html
" + } + :public object method get_doc_block {text {restVar ""}} { + set lines [split $text \n] + set docBlock "" + set i 0 + set nrLines [llength $lines] + while {[string trim [lindex $lines $i]] eq "" && $i < $nrLines} {incr i} + while {$i < $nrLines} { + set line [string trim [lindex $lines $i]] + incr i + if {[string index $line 0] ne "#"} break + append docBlock [string range $line 1 end] \n + } + if {$restVar ne ""} { + upvar $restVar rest + set rest [join [lrange $lines $i end] \n] + } + #ns_log notice "=================== get_doc_block RETURNS <$docBlock>" + return $docBlock + } + :public object method update_object_doc {scope obj doc_string} { + # + # Update the api browser informatio nsvs with information about + # the provided object. + # + # If no doc string is provided, try to get it from the object + # definition. + # + if {$doc_string eq ""} { + set doc_string [:get_doc_block [:get_init_block $scope $obj]] + } -::xotcl::Object instproc __api_make_doc {inst proc_name} { - upvar doc doc private private public public deprecated deprecated - if {$doc eq ""} { - set doc_elements(main) "" - } else { - ad_parse_documentation_string $doc doc_elements + ad_parse_documentation_string $doc_string doc_elements + # + # Initialize dictionary with default values and update it with the + # information from parsing the doc string. + # + set doc [dict create \ + param "" \ + protection public \ + varargs_p false \ + deprecated_p false \ + warn_p false \ + script [::xo::api script_name $scope] \ + ] + set doc [dict replace $doc {*}[array get doc_elements]] + + # + # TODO: add actual parameters to flags and defaults (also required, ...) + # + set switches {}; set flags {} + foreach l [dict get $doc param] { + if {[regexp {^([^ ]+)\s} $l . word]} { + lappend switches $word + lappend flags $word "" + } + } + set proc_index [::xo::api object_index $scope $obj] + set doc [dict replace $doc \ + default_values "" \ + switches $switches \ + positionals "" \ + flags $flags \ + ] + nsv_set api_proc_doc $proc_index $doc + nsv_set api_library_doc $proc_index $doc + + set file_index [dict get $doc script] + if {[nsv_exists api_library_doc $file_index]} { + array set elements [nsv_get api_library_doc $file_index] + } + set oldDoc [expr {[info exists elements(main)] ? \ + [lindex $elements(main) 0] : ""}] + set prefix "This file defines the following Objects and Classes" + set entry [::xo::api object_link $scope $obj] + if {![string match "*$prefix*" $oldDoc]} { + append oldDoc "

$prefix: $entry" + } else { + append oldDoc ", $entry" + } + set elements(main) [list $oldDoc] + #my log "elements = [array get elements]" + nsv_set api_library_doc $file_index [array get elements] + + if {[::nsf::dispatch $obj ::nsf::methods::object::info::hastype ::nx::Class]} { + # + # nx classes + # + foreach protection {public protected private} { + foreach m [::nsf::dispatch $obj ::nsf::methods::class::info::methods \ + -callprotection $protection -type scripted] { + set docBlock [:get_doc_block \ + [::nsf::dispatch $obj ::nsf::methods::class::info::method body $m]] + ::xo::api update_method_doc \ + -protection $protection \ + -deprecated=false \ + -debug=false \ + $scope $obj \ + inst $m $docBlock + } + } + } + if {[::nsf::dispatch $obj ::nsf::methods::object::info::hastype ::nx::Object]} { + # + # nx objects + # + foreach protection {public protected private} { + foreach m [::nsf::dispatch $obj ::nsf::methods::object::info::methods \ + -callprotection $protection -type scripted] { + set docBlock [:get_doc_block \ + [::nsf::dispatch $obj ::nsf::methods::object::info::method body $m]] + ::xo::api update_method_doc \ + -protection $protection \ + -deprecated=false \ + -debug=false \ + $scope $obj \ + "" $m $docBlock + } + } + } + } - set defaults [list] - foreach a [::xo::getObjectProperty [self] ${inst}args $proc_name] { - if {[::xo::getObjectProperty [self] ${inst}argdefault $proc_name $a d]} {lappend defaults $a $d} + + :public object method update_method_doc { + {-protection "public"} + {-deprecated:switch false} + {-debug:switch false} + {-warn:switch false} + scope obj inst proc_name + docString + } { + set varargs_p [expr {"args" in [::xo::getObjectProperty $obj ${inst}args $proc_name]}] + + set doc [dict create \ + param "" \ + protection $protection \ + varargs_p $varargs_p \ + deprecated_p false \ + warn_p false \ + script [::xo::api script_name $scope] \ + main "" \ + flags "" \ + switches "" \ + ] + + if {$docString ne ""} { + ad_parse_documentation_string $docString doc_elements + set doc [dict replace $doc {*}[array get doc_elements]] + } + + set defaults [list] + foreach a [::xo::getObjectProperty $obj ${inst}args $proc_name] { + if {[::xo::getObjectProperty $obj ${inst}argdefault $proc_name $a d]} { + lappend defaults $a $d + } + } + + foreach def [::xo::getObjectProperty $obj ${inst}methodparameter $proc_name] { + lassign $def f default + set pair [split [lindex $f 0 0] :] + lassign $pair flaggedName flags + if {[string range $flaggedName 0 0] eq "-"} { + set isFlag 1 + set name [string range $flaggedName 1 end] + } else { + set isFlag 0 + set name $flaggedName + } + if {$isFlag} { + dict lappend doc switches $name + dict lappend doc flags $name $flags + #my log "default_value $proc_name: $sw -> '[lindex $f 1]' <$pair/$f>" + if {$flags eq "switch" && $default eq ""} { + set default "false" + } + } + #my log "default_value $proc_name: $sw -> 'default' <$pair/$f>" + if {[llength $def] > 1} {lappend defaults $name $default} + } + dict set doc default_values $defaults + dict set doc positionals [::xo::getObjectProperty $obj ${inst}args $proc_name] + + # argument documentation finished + set proc_index [::xo::api proc_index $scope $obj ${inst}proc $proc_name] + if {![nsv_exists api_proc_doc $proc_index]} { + nsv_lappend api_proc_doc_scripts [dict get $doc script] $proc_index + } + #ns_log notice "SETTING api_proc_doc '$proc_index' <$doc>" + nsv_set api_proc_doc $proc_index $doc + } + + :public object method get_init_block {scope obj} { + # + # Get the init block of an object/class or return empty + # + if {$scope eq ""} { + if {[::nsf::var::exists $obj __cmd(__initblock)]} { + return [::nsf::var::set $obj __cmd(__initblock)] + } + } else { + if {[$scope do ::nsf::var::exists $obj __cmd(__initblock)]} { + return [$scope do [::nsf::var::exists $obj __cmd(__initblock)]] + } + } + return "" } - set public [expr {$private ? false : true}] - set doc_elements(public_p) $public - set doc_elements(private_p) $private - set doc_elements(deprecated_p) $deprecated - set doc_elements(warn_p) $deprecated - set doc_elements(varargs_p) [expr {"args" in [::xo::getObjectProperty [self] ${inst}args $proc_name]}] - set doc_elements(flags) [list] - set doc_elements(switches) [list] - foreach f [my info ${inst}nonposargs $proc_name] { - set pair [split [lindex $f 0 0] :] - set sw [string range [lindex $pair 0] 1 end] - lappend doc_elements(switches) $sw - lappend doc_elements(flags) $sw [lindex $pair 1] - #my log "default_value $proc_name: $sw -> '[lindex $f 1]' <$pair/$f>" - if {[lindex $pair 1] eq "switch" && [lindex $f 1] eq ""} { - set default "false" + + :public object method get_object_source {scope obj} { + set init_block [:get_init_block $scope $obj] + if {$init_block ne ""} { + set dummy [:get_doc_block $init_block body] + return $body } else { - set default [lindex $f 1] + if {$scope eq ""} { + return [$obj serialize] + } else { + return [$scope do $obj serialize] + } } - #my log "default_value $proc_name: $sw -> 'default' <$pair/$f>" - lappend defaults $sw $default } - set doc_elements(default_values) $defaults - set doc_elements(positionals) [::xo::getObjectProperty [self] ${inst}args $proc_name] - # argument documentation finished - set scope [::xotcl::api scope] - set doc_elements(script) [::xotcl::api script_name $scope] - set proc_index [::xotcl::api proc_index $scope [self] ${inst}proc $proc_name] - if {![nsv_exists api_proc_doc $proc_index]} { - nsv_lappend api_proc_doc_scripts $doc_elements(script) $proc_index + + :public object method get_method_source {scope obj prefix method} { + if {$scope eq ""} { + return [::Serializer methodSerialize $obj $method $prefix] + } else { + return [$scope do ::Serializer methodSerialize $obj $method $prefix] + } } - #my log "doc_elements=[array get doc_elements]" - #my log "SETTING api_proc_doc '$proc_index'" - nsv_set api_proc_doc $proc_index [array get doc_elements] + + :public object method update_nx_docs {{objects ""}} { + if {[llength $objects] == 0} { + set objects [nx::Object info instances -closure] + } + + foreach o $objects { + # + # check general per-object documentation + # + if {[string match ::nx::* $o]} continue + ::xo::api update_object_doc "" $o "" + } + + } } +::nx::Class public method init {} { + set r [next] + # + # When loading the blueprint, ::xo::api might not be available yet + # + if {[info commands ::xo::api] ne ""} { + ::xo::api update_object_doc "" [self] "" + #ns_log notice "METHODS [self] <[:info methods]>" + } else { + #ns_log notice "[self] init: no <::xo::api> available" + } + return $r +} + ::xotcl::Object instproc __api_make_forward_doc {inst method_name} { upvar doc doc private private public public deprecated deprecated if {$doc eq ""} { @@ -197,9 +536,7 @@ #my log "doc_elements=[array get doc_elements]" } set defaults [list] - set public [expr {$private ? false : true}] - set doc_elements(public_p) $public - set doc_elements(private_p) $private + set doc_elements(protection) [expr {$private ? "protected" : "public"}] set doc_elements(deprecated_p) $deprecated set doc_elements(warn_p) $deprecated set doc_elements(varargs_p) false @@ -208,9 +545,9 @@ set doc_elements(default_values) [list] set doc_elements(positionals) [list] # argument documentation finished - set scope [::xotcl::api scope] - set doc_elements(script) [::xotcl::api script_name $scope] - set proc_index [::xotcl::api proc_index $scope [self] ${inst}forward $method_name] + set scope [::xo::api scope] + set doc_elements(script) [::xo::api script_name $scope] + set proc_index [::xo::api proc_index $scope [self] ${inst}forward $method_name] if {![nsv_exists api_proc_doc $proc_index]} { nsv_lappend api_proc_doc_scripts $doc_elements(script) $proc_index } @@ -219,55 +556,42 @@ nsv_set api_proc_doc $proc_index [array get doc_elements] } -if {[info commands ::nx::Object] ne ""} { +::xotcl::Object instproc ad_proc { + {-private:switch false} + {-deprecated:switch false} + {-warn:switch false} + {-debug:switch false} + proc_name + arguments:parameter,0..* + doc + body +} { + uplevel [list [self] proc $proc_name $arguments $body] + ::xo::api update_method_doc \ + -protection [expr {$private ? "private" : "public"}] \ + -deprecated=$deprecated \ + -debug=$private \ + [::xo::api scope] [self] \ + "" $proc_name $doc +} - ::xotcl::Object instproc ad_proc { - {-private:switch false} - {-deprecated:switch false} - {-warn:switch false} - {-debug:switch false} - proc_name - arguments:parameter,0..* - doc - body - } { - uplevel [list [self] proc $proc_name $arguments $body] - my __api_make_doc "" $proc_name - } - - ::xotcl::Class instproc ad_instproc { - {-private:switch false} - {-deprecated:switch false} - {-warn:switch false} - {-debug:switch false} - proc_name - arguments:parameter,0..* - doc - body - } { - uplevel [list [self] instproc $proc_name $arguments $body] - my __api_make_doc inst $proc_name - } -} else { - ::xotcl::Object instproc ad_proc { - {-private:switch false} - {-deprecated:switch false} - {-warn:switch false} - {-debug:switch false} - proc_name arguments doc body} { - uplevel [list [self] proc $proc_name $arguments $body] - my __api_make_doc "" $proc_name - } - - ::xotcl::Class instproc ad_instproc { - {-private:switch false} - {-deprecated:switch false} - {-warn:switch false} - {-debug:switch false} - proc_name arguments doc body} { - uplevel [list [self] instproc $proc_name $arguments $body] - my __api_make_doc inst $proc_name - } +::xotcl::Class instproc ad_instproc { + {-private:switch false} + {-deprecated:switch false} + {-warn:switch false} + {-debug:switch false} + proc_name + arguments:parameter,0..* + doc + body +} { + uplevel [list [self] instproc $proc_name $arguments $body] + ::xo::api update_method_doc \ + -protection [expr {$private ? "private" : "public"}] \ + -deprecated=$deprecated \ + -debug=$private \ + [::xo::api scope] [self] \ + inst $proc_name $doc } ::xotcl::Object instproc ad_forward { @@ -290,51 +614,10 @@ my __api_make_forward_doc inst $method_name } - - ::xotcl::Object instproc ad_doc {doc_string} { - ad_parse_documentation_string $doc_string doc_elements - set scope [::xotcl::api scope] - set doc_elements(script) [::xotcl::api script_name $scope] - set proc_index [::xotcl::api object_index $scope [self]] - - #if {![nsv_exists api_proc_doc $proc_index]} { - # nsv_lappend api_proc_doc_scripts $doc_elements(script) $proc_index - #} - set doc_elements(public_p) true - set doc_elements(private_p) false - set doc_elements(varargs_p) false - set doc_elements(deprecated_p) false - set doc_elements(warn_p) false - set doc_elements(default_values) "" - set doc_elements(switches) "" - set doc_elements(positionals) "" - set doc_elements(flags) "" - nsv_set api_proc_doc $proc_index [array get doc_elements] - nsv_set api_library_doc \ - $proc_index \ - [array get doc_elements] - - set file_index $doc_elements(script) - - if {[nsv_exists api_library_doc $file_index]} { - array set elements [nsv_get api_library_doc $file_index] - } - set oldDoc [expr {[info exists elements(main)] ? \ - [lindex $elements(main) 0] : ""}] - set prefix "This file defines the following Objects and Classes" - set entry [::xotcl::api object_link $scope [self]] - if {![string match "*$prefix*" $oldDoc]} { - append oldDoc "

$prefix: $entry" - } else { - append oldDoc ", $entry" - } - set elements(main) [list $oldDoc] - #my log "elements = [array get elements]" - nsv_set api_library_doc $file_index [array get elements] + ::xo::api update_object_doc "" [self] $doc_string } - # Class ::Test -ad_doc { # Test Class for the documentation of # Classes, Index: openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl,v diff -u -r1.31.2.1 -r1.31.2.2 --- openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 2 Dec 2015 08:30:11 -0000 1.31.2.1 +++ openacs-4/packages/xotcl-core/tcl/06-package-procs.tcl 30 Dec 2015 18:09:14 -0000 1.31.2.2 @@ -194,7 +194,7 @@ # compatibility, but complain in ns_log. # # (E.g. hypermail2xowiki uses this) - ns_log notice "Could not find ::xo::Package with key $package_key ($package_id)" + ns_log warning "Could not find ::xo::Package with key $package_key ($package_id)" set package_class [self] } Index: openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl,v diff -u -r1.49.2.2 -r1.49.2.3 --- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 3 Oct 2015 18:28:39 -0000 1.49.2.2 +++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl 30 Dec 2015 18:09:14 -0000 1.49.2.3 @@ -124,7 +124,7 @@ } } fileSpooler proc tick {} { - if {[catch {my cleanup} errorMsg]} {ns_log notice "Error during filespooler cleanup: $errorMsg"} + if {[catch {my cleanup} errorMsg]} {ns_log error "Error during filespooler cleanup: $errorMsg"} my set to [after [my set tick_interval] [list [self] tick]] } fileSpooler tick @@ -344,7 +344,7 @@ set subs1 [list] foreach s $subscriptions($key) { if {[catch {$s $method $argument} errMsg]} { - ns_log notice "error in $method to subscriber $s (key=$key): $errMsg" + ns_log error "error in $method to subscriber $s (key=$key): $errMsg" $s destroy } else { lappend subs1 $s Index: openacs-4/packages/xotcl-core/tcl/context-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/context-procs.tcl,v diff -u -r1.65.2.3 -r1.65.2.4 --- openacs-4/packages/xotcl-core/tcl/context-procs.tcl 7 Dec 2015 16:58:07 -0000 1.65.2.3 +++ openacs-4/packages/xotcl-core/tcl/context-procs.tcl 30 Dec 2015 18:09:14 -0000 1.65.2.4 @@ -12,7 +12,7 @@ namespace eval ::xo { - Class create Context -ad_doc { + ::xotcl::Class create Context -ad_doc { This class provides a context for evaluation, somewhat similar to an activation record in programming languages. It combines the parameter declaration (e.g. of a page, an includelet) with the actual parameters @@ -26,7 +26,8 @@ locale } - # syntactic sugar for includelets, to allow the same syntax as + # + # Syntactic sugar for includelets, to allow the same syntax as # for "Package initialize ...."; however, we do not allow currently # do switch user or package id etc., just the parameter declaration Context instproc initialize {{-parameter ""}} { Index: openacs-4/packages/xotcl-core/tcl/doc-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/doc-procs.tcl,v diff -u -r1.1.2.1 -r1.1.2.2 --- openacs-4/packages/xotcl-core/tcl/doc-procs.tcl 10 Sep 2015 08:10:45 -0000 1.1.2.1 +++ openacs-4/packages/xotcl-core/tcl/doc-procs.tcl 30 Dec 2015 18:09:14 -0000 1.1.2.2 @@ -1,9 +1,9 @@ ad_library { - generic doc procs + generic doc procs - @creation-date 2015-04-30 - @author Gustaf Neumann - @cvs-id $Id$ + @creation-date 2015-04-30 + @author Gustaf Neumann + @cvs-id $Id$ } namespace eval ::xo { @@ -23,18 +23,19 @@ upvar $methods_ref methods set infokind $kind if {$kind eq "instproc"} {append infokind s} - ::xotcl::api scope_from_object_reference scope e - foreach method [xo::getObjectProperty $e $kind] { + ::xo::api scope_from_object_reference scope e + if {$kind eq "proc"} {set prefix "→ "} {set prefix ""} + foreach methodName [xo::getObjectProperty $e $kind] { if {$documented_methods} { - set proc_index [::xotcl::api proc_index $scope $e $kind $method] - #my msg "check $method => [nsv_exists api_proc_doc $proc_index]" - if {[nsv_exists api_proc_doc $proc_index]} { - lappend methods $method - } - } else { - lappend methods $method - } - } + set proc_index [::xo::api proc_index $scope $e $kind $methodName] + #my msg "check $methodName => [nsv_exists api_proc_doc $proc_index]" + if {[nsv_exists api_proc_doc $proc_index]} { + lappend methods $prefix$methodName + } + } else { + lappend methods $prefix$methodName + } + } } ad_proc dotclass {{-is_focus 0} {-documented_methods 1} e} { @@ -55,9 +56,10 @@ } } append definition "|" - ::xotcl::api scope_from_object_reference scope e + ::xo::api scope_from_object_reference scope e set methods [list] - dot_append_method -documented_methods $documented_methods $e methods instproc + dot_append_method -documented_methods $documented_methods $e methods proc + dot_append_method -documented_methods $documented_methods $e methods instproc dot_append_method -documented_methods $documented_methods $e methods instforward foreach method [lsort $methods] {append definition "$method\\l" } append definition "\}\"\];\n" @@ -85,98 +87,94 @@ set mclasses {} foreach e $things { - if {![::xotcl::Object isobject $e]} continue - if {$omit_base_classes && ($e eq "::xotcl::Object" || $e eq "::xotcl::Class")} continue - lappend [expr {[::xotcl::Object isclass $e] ? "classes" : "objects"}] $e + if {![::nsf::is object $e] || ($omit_base_classes && [::nsf::is baseclass $e])} continue + lappend [expr {[::nsf::is class $e] ? "classes" : "objects"}] $e } set instances "" if {$with_instance_relations} { - foreach e $things { - if {![::xotcl::Object isobject $e]} continue - if {$omit_base_classes && ($e eq "::xotcl::Object" || $e eq "::xotcl::Class")} continue - set c [$e info class] - if {$omit_base_classes && ($c eq "::xotcl::Object" || $c eq "::xotcl::Class")} continue - if {$c ni $things} {lappend iclasses $c} - append instances "[dotquote $e]->[dotquote $c];\n" - } + foreach e $things { + if {![::nsf::is object $e] || ($omit_base_classes && [::nsf::is baseclass $e])} continue + set c [$e info class] + if {$omit_base_classes && [::nsf::is baseclass $c]} continue + if {$c ni $things} {lappend iclasses $c} + append instances "[dotquote $e]->[dotquote $c];\n" + } } set superclasses "" foreach e $classes { - if {![::xotcl::Object isobject $e]} continue - if {$e eq "::xotcl::Object"} continue - set reduced_sc [list] - foreach sc [::xo::getObjectProperty $e superclass] { - if {$omit_base_classes && ($sc eq "::xotcl::Object" || $sc eq "::xotcl::Class")} continue - lappend reduced_sc $sc - } - if {$reduced_sc eq {}} continue - foreach sc $reduced_sc { - if {$sc in $things} { - append superclasses "[dotquote $e]->[dotquotel $sc];\n" - } - } + if {![::nsf::is object $e]} continue + set reduced_sc [list] + foreach sc [::xo::getObjectProperty $e superclass] { + if {$omit_base_classes && [::nsf::is baseclass $sc]} continue + lappend reduced_sc $sc + } + if {$reduced_sc eq {}} continue + foreach sc $reduced_sc { + if {$sc in $things} { + append superclasses "[dotquote $e]->[dotquotel $sc];\n" + } + } } - set children "" - set mixins "" - foreach e $things { - if {![::xotcl:::Object isobject $e]} continue - if {$omit_base_classes && ($e eq "::xotcl::Object" || $e eq "::xotcl::Class")} continue - if {$with_children} { - foreach c [$e info children] { - if {$c ni $things} continue - append children "[dotquote $c]->[dotquote $e];\n" - } - } - set m [xo::getObjectProperty $e mixin] - #puts "-- $e mixin $m" - if {$m eq ""} continue - foreach mixin $m { - if {$mixin ni $things} {lappend mclasses $m} - append mixins "[dotquote $e]->[dotquotel $mixin];\n" - } - } - set tclasses "" - set instmixins "" - foreach e $classes { - set m [xo::getObjectProperty $e instmixin] - #puts "-- $e instmixin $m" - if {$m eq ""} continue - #foreach mixin $m { - # append tclasses [dotclass -documented_methods $documented_methods $mixin] - #} + set children "" + set mixins "" + foreach e $things { + if {![::nsf::is object $e] || ($omit_base_classes && [::nsf::is baseclass $e])} continue + if {$with_children} { + foreach c [$e info children] { + if {$c ni $things} continue + append children "[dotquote $c]->[dotquote $e];\n" + } + } + set m [xo::getObjectProperty $e mixin] + #puts "-- $e mixin $m" + if {$m eq ""} continue + foreach mixin $m { + if {$mixin ni $things} {lappend mclasses $m} + append mixins "[dotquote $e]->[dotquotel $mixin];\n" + } + } + set tclasses "" + set instmixins "" + foreach e $classes { + set m [xo::getObjectProperty $e instmixin] + #puts "-- $e instmixin $m" + if {$m eq ""} continue + #foreach mixin $m { + # append tclasses [dotclass -documented_methods $documented_methods $mixin] + #} - foreach mixin $m { - if {$mixin ni $things} {lappend mclasses $mixin} - append instmixins "[dotquote $e]->[dotquotel $mixin];\n" - } - } + foreach mixin $m { + if {$mixin ni $things} {lappend mclasses $mixin} + append instmixins "[dotquote $e]->[dotquotel $mixin];\n" + } + } - foreach e $classes { - append tclasses [dotclass -is_focus [expr {$e eq $current_object}] -documented_methods $documented_methods $e] - } - set tobjects {} - foreach e $objects { - append tobjects [dotobject $e] - } - set tmclasses {} - foreach e $mclasses { - append tmclasses [dotobject $e] - } - set ticlasses {} - foreach e $iclasses { - append ticlasses [dotobject $e] - } + foreach e $classes { + append tclasses [dotclass -is_focus [expr {$e eq $current_object}] -documented_methods $documented_methods $e] + } + set tobjects {} + foreach e $objects { + append tobjects [dotobject $e] + } + set tmclasses {} + foreach e $mclasses { + append tmclasses [dotobject $e] + } + set ticlasses {} + foreach e $iclasses { + append ticlasses [dotobject $e] + } + + #label = \".\\n.\\nObject relations of [self]\" + #edge \[dir=back, constraint=0\] \"::Decorate_Action\" -> \"::Action\"; + set objects [join [dotquotel $objects] {; }] + #set classes [join [dotquotel $classes] {; }] + set imcolor hotpink4 - #label = \".\\n.\\nObject relations of [self]\" - #edge \[dir=back, constraint=0\] \"::Decorate_Action\" -> \"::Action\"; - set objects [join [dotquotel $objects] {; }] - #set classes [join [dotquotel $classes] {; }] - set imcolor hotpink4 - - set font "fontname = \"Helvetica\",fontsize = 8," - #set font "fontname = \"Bitstream Vera Sans\",fontsize = 8," - # rankdir = BT; labeldistance = 20; - return "digraph { + set font "fontname = \"Helvetica\",fontsize = 8," + #set font "fontname = \"Bitstream Vera Sans\",fontsize = 8," + # rankdir = BT; labeldistance = 20; + return "digraph { dpi = $dpi; rankdir = BT; node \[$font shape=record\]; $tclasses @@ -196,6 +194,6 @@ # Local variables: # mode: tcl -# tcl-indent-level: 2 +# tcl-indent-level: 4 # indent-tabs-mode: nil # End: Index: openacs-4/packages/xotcl-core/www/index.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/www/index.tcl,v diff -u -r1.8.2.1 -r1.8.2.2 --- openacs-4/packages/xotcl-core/www/index.tcl 10 Sep 2015 08:10:45 -0000 1.8.2.1 +++ openacs-4/packages/xotcl-core/www/index.tcl 30 Dec 2015 18:09:14 -0000 1.8.2.2 @@ -26,7 +26,7 @@ proc local_link cl { upvar all_classes all_classes - if {$all_classes || ![string match "::xotcl::*" $cl]} { + if {$all_classes || (![string match "::xotcl::*" $cl] && ![string match "::nx::*" $cl])} { return "$cl" } else { return $cl @@ -57,10 +57,11 @@ lappend classes {*}[nx::Class info instances -closure] } foreach cl [lsort $classes] { - if {!$all_classes && [string match "::xotcl::*" $cl]} \ - continue + if {!$all_classes && ([string match "::xotcl::*" $cl] || [string match "::nx::*" $cl])} { + continue + } - append output "

  • [::xotcl::api object_link {} $cl]