- Update to OpenACS 5.9.1

catalog/xotcl-core.de_DE.ISO-8859-1.xml

@@ -2,8 +2,12 @@
 <message_catalog package_key="xotcl-core" locale="de_DE" charset="ISO-8859-1">
 
   <msg key="add">Neu: %type%</msg>
+  <msg key="add_item">Element hinzufgen</msg>
   <msg key="add_long">Neue Seite vom Type %type% erzeugen</msg>
+  <msg key="create_new_type">Neuen %type% erstellen</msg>
+  <msg key="delete_item">Element lschen</msg>
   <msg key="edit_item">Editieren</msg>
+  <msg key="edit_type">%type% bearbeiten</msg>
   <msg key="has_entered_the_room">has entered the room</msg>
   <msg key="live_revision">Aktuelle Version</msg>
   <msg key="No_Data">Keine Daten</msg>
@@ -14,4 +18,5 @@ Sie haben keine ausreichende Berechtigung, um die Methode %method% am Objekt %ob
 &lt;/blockquote&gt;</msg>
   <msg key="revision_title">Versionen des Eintrags</msg>
   <msg key="revisions">Verlauf</msg>
+  <msg key="view_item">Element anzeigen</msg>
 </message_catalog>

catalog/xotcl-core.en_US.ISO-8859-1.xml

@@ -10,11 +10,11 @@
   <msg key="edit_type">Edit %type%</msg>
   <msg key="has_entered_the_room">has entered the room</msg>
   <msg key="live_revision">Live Revision</msg>
-  <msg key="No_Data">No Data</msg>
   <msg key="nobody">Guest</msg>
+  <msg key="No_Data">No Data</msg>
   <msg key="permission_denied">Permission Denied</msg>
   <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt;
-You don&#39;t have sufficient permissions for performing method %method% on object %object%.
+You don't have sufficient permissions for performing method %method% on object %object%.
 &lt;/blockquote&gt;</msg>
   <msg key="revision_title">Revisions of Entry</msg>
   <msg key="revisions">Revisions</msg>

catalog/xotcl-core.es_ES.ISO-8859-1.xml

@@ -10,6 +10,9 @@
   <msg key="edit_type">Editar %type%</msg>
   <msg key="has_entered_the_room">ha entrado en la sala</msg>
   <msg key="live_revision">Revisin Viva</msg>
+  <msg key="No_Data">Sin datos</msg>
+  <msg key="nobody">Invitado</msg>
+  <msg key="permission_denied">Permiso denegado</msg>
   <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt;
 Usted no tiene permisos suficientes para realizar mtodo %method% en objeto %object%.
 &lt;/blockquote&gt;</msg>

catalog/xotcl-core.it_IT.ISO-8859-1.xml

+<?xml version="1.0" encoding="ISO-8859-1"?>
+<message_catalog package_key="xotcl-core" locale="it_IT" charset="ISO-8859-1">
+
+  <msg key="add">Aggiungi %type%</msg>
+  <msg key="add_item">Aggiungi Elemento</msg>
+  <msg key="add_long">Aggiungi nuovo elemento di tipo %type%</msg>
+  <msg key="create_new_type">Crea Nuovo %type%</msg>
+  <msg key="delete_item">Elimina Elemento</msg>
+  <msg key="edit_item">Edita Elemento</msg>
+  <msg key="edit_type">Edita %type%</msg>
+  <msg key="has_entered_the_room"> entrato nella stanza</msg>
+  <msg key="live_revision">Revisione Corrente</msg>
+  <msg key="No_Data">Nessun Dato</msg>
+  <msg key="nobody">Ospite</msg>
+  <msg key="permission_denied">Permesso Negato</msg>
+  <msg key="policy-error-insufficient_permissions">&lt;blockquote&gt; Non hai permessi sufficienti ad eseguire il metodo %method% sull&#39;oggetto %object%. &lt;/blockquote&gt;</msg>
+  <msg key="revision_title">Revisioni della Voce</msg>
+  <msg key="revisions">Revisioni</msg>
+  <msg key="view_item">Vedi Elemento</msg>
+</message_catalog>

lib/revisions-postgresql.xql

@@ -3,27 +3,6 @@
 <queryset>
   <rdbms><type>postgresql</type><version>7.1</version></rdbms>
 
-  <fullquery name="revisions_info">      
-    <querytext>
-    select  ci.name, n.revision_id as version_id,
-      person__name(n.creation_user) as author,
-      n.creation_user as author_id,
-      to_char(n.last_modified,'YYYY-MM-DD HH24:MI:SS') as last_modified_ansi,
-      n.description,
-      acs_permission__permission_p(n.revision_id,:user_id,'admin') as admin_p,
-      acs_permission__permission_p(n.revision_id,:user_id,'delete') as delete_p,
-      char_length(n.data) as content_size,
-      content_revision__get_number(n.revision_id) as version_number	
-    from cr_revisionsi n, cr_items ci
-    where ci.item_id = n.item_id and ci.item_id = :page_id
-          and exists (select 1 from acs_object_party_privilege_map m
-                      where m.object_id = n.revision_id
-                        and m.party_id = :user_id
-                        and m.privilege = 'read')
-	order by n.revision_id desc
-    </querytext>
-  </fullquery> 
-
   <fullquery name="revisions_info">
     <rdbms><type>postgresql</type><version>8.4</version></rdbms>
       <querytext>

tcl/04-library-procs.tcl

@@ -18,7 +18,7 @@ ad_library {
 #
 # Load a required file:
 #
-#   Source a file, which is requred by the current file
+#   Source a file, which is required by the current file
 #   Filename is without path and .tcl
 #
 #     ::xo::library require filename
@@ -82,6 +82,7 @@ namespace eval ::xo {
     if {![nsv_exists [self]-loaded $otherfile]} {
       my log "--sourcing $otherfile"
       apm_source $otherfile
+      nsv_set [self]-loaded $otherfile 1
     }
   }
 
@@ -103,9 +104,7 @@ namespace eval ::xo {
     #my log "--check nsv_exists $vn $dirname/$myfile [nsv_exists $vn $dirname/$myfile]"
     if {[nsv_exists $vn $dirname/$myfile]} {
       foreach file [nsv_get $vn $dirname/$myfile] {
-        #my log "--sourcing dependent $dirname/$file"
-        #apm_source $dirname/$file
-        #my log "--sourcing dependent $file"
+        my log "--sourcing dependent $file"
         apm_source $file
       }
     }

tcl/06-package-procs.tcl

@@ -23,13 +23,11 @@ namespace eval ::xo {
     my instvar package_key
     if {[info exists privilege]} {
       set sql [::xo::dc select -vars package_id \
-                   -from "apm_packages, acs_object_party_privilege_map ppm, site_nodes s" \
+                   -from "apm_packages, site_nodes s" \
                    -where {
                      package_key = :package_key 
-                     and s.object_id = package_id 
-                     and ppm.object_id = package_id 
-                     and ppm.party_id = :party_id
-                     and ppm.privilege = :privilege
+                     and s.object_id = package_id
+                     and acs_permission__permission_p(package_id, :party_id, :privilege)
                    } -limit 1]
       ::xo::dc get_value get_package_id $sql
     } else {
@@ -194,7 +192,7 @@ namespace eval ::xo {
         # 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]
       }
 
@@ -249,9 +247,24 @@ namespace eval ::xo {
                            -package_id $package_id \
                            -retry false]
     set success 0
-    if {$parameter_obj ne ""} {
+
+    if {$parameter_obj ne "" && [$parameter_obj set scope] ne "global"} {
       set value [$parameter_obj get -package_id $package_id]
-      if {[$parameter_obj set __success]} {return $value}
+      #ns_log notice "core: get_param for $attribute after GET: [$parameter_obj serialize] -> '$value'"
+      #if {$value ne "" || [$parameter_obj set __success]} {return $value}
+      #
+      # The returned '$value' might be a value set for the actual
+      # package instance, or the default for the package_parameter as
+      # defined by the package parameter definition in the xml file. If
+      # the value was not specified explicitly, and the provided
+      # default for this command is not empty, return the provided
+      # default.
+      #
+      if {![$parameter_obj set __success] && $value eq "" && $default ne ""} {
+        return $default
+      } else {
+        return $value
+      }
     }
     return [parameter::get_global_value \
                    -package_key [my set package_key] \
@@ -429,10 +442,12 @@ namespace eval ::xo {
     if { [lang::util::translator_mode_p] } {
       set text [::xo::localize $text 1]
     }
-    #my log "--after adp"
-    return $text
+    #my log "--after adp $text"
+
+    return [::xo::remove_escapes $text]
   }
-  
+
+        
   #ns_log notice [::xo::Package serialize]
 
 }

tcl/06-param-procs.tcl

@@ -277,8 +277,11 @@ namespace eval ::xo {
     }
     set package_id [my get_package_id_from_package_key -package_key $package_key]
     set value [$parameter_obj get -package_id $package_id]
-    if {$value eq "" && [$parameter_obj set __success] == 0} {return $default}
-    return $value
+    if {$value eq "" && [$parameter_obj set __success] == 0 && [info exists default]} {
+      return $default
+    } else {
+      return $value
+    }
   }
 
   parameter proc get {

tcl/10-recreation-procs.tcl

@@ -15,7 +15,7 @@ ad_library {
 
 if {![::xotcl::Object isclass ::xotcl::RecreationClass]} {
   ::xotcl::Class create ::xotcl::RecreationClass -ad_doc {
-    <p>This meta-class controlls the behavior of classes (and optionally
+    <p>This meta-class controls the behavior of classes (and optionally
     their instances), when the classes (or their instances) are    
     overwritten by same named new objects; we call this situation
     a recreate of an object.</p>
@@ -28,13 +28,13 @@ if {![::xotcl::Object isclass ::xotcl::RecreationClass]} {
     instances of class ::xotcl::Object. </p>
 
     <p>This can be a problem when the class instances are not 
-    reloaded and when they should survife the redefintion with the
+    reloaded and when they should survife the redefinition with the
     same class relationships. Therefore we define a 
     meta class RecreationClass, which can be used to parameterize 
     the behavior on redefinitions. Alternatively, Classes or objects
     could provide their own recreate methods.</p>
 
-    <p>Per default, this meta-class handles only the class redefintion
+    <p>Per default, this meta-class handles only the class redefinition
     case and does only a reconfigure on the class object (in order
     to get e.g. ad_doc updated).</p>
     The following parameters are defined:
@@ -167,7 +167,7 @@ if {[string match "1.3.*" $version]} {
   ns_log notice "-- softrecreate"
   ::xotcl::configure softrecreate true
 
-  Class RR -instproc recreate args { 
+  Class create RR -instproc recreate args { 
     my log "-- [self args]"; next
   } -instproc create args { 
     my log "-- [self args]"; next

tcl/20-Ordered-Composite-procs.tcl

@@ -10,7 +10,7 @@ ad_library {
 }
 
 namespace eval ::xo {
-  Class OrderedComposite 
+  Class create OrderedComposite 
 
   OrderedComposite instproc show {} {
     next
@@ -105,7 +105,8 @@ namespace eval ::xo {
     }
     if {$errorOccurred} {error $errorMsg}
   }
-  Class OrderedComposite::ChildManager -instproc init args {
+
+  Class create OrderedComposite::ChildManager -instproc init args {
     set r [next]
     #set parent [self callingobject] ;# not a true calling object (ns-eval), but XOTcl 1 honors it
     #set parent [my info parent] ;# is ok in XOTcl 2, since the namespace is honored correctly
@@ -121,9 +122,9 @@ namespace eval ::xo {
     return $r
   }
 
-  Class OrderedComposite::Child -instproc __after_insert {} {;}
+  Class create OrderedComposite::Child -instproc __after_insert {} {;}
 
-  Class OrderedComposite::IndexCompare
+  Class create OrderedComposite::IndexCompare
   OrderedComposite::IndexCompare instproc __compare {a b} {
     set by [my set __orderby]
     set x [$a set $by]
@@ -165,7 +166,7 @@ namespace eval ::xo {
     }
   }
 
-  Class OrderedComposite::MethodCompare
+  Class create OrderedComposite::MethodCompare
   OrderedComposite::MethodCompare instproc __compare {a b} {
     set by [my set __orderby]
     set x [$a $by]

tcl/30-widget-procs.tcl

 ::xo::library doc {
-  XOTcl HTML Widget Classes based on tdom
+  XOTcl HTML Widget Classes based on tDOM
 
   @author Gustaf Neumann (neumann@wu-wien.ac.at)
   @author Neophytos Demetriou (k2pts@phigita.net)
@@ -109,7 +109,7 @@ namespace eval ::xo::tdom {
     #
     # autorendering means that after creating an ordered composite,
     # the topmost element is automatically rendered. This makes
-    # the ::xo::tdom classes behave more like plain tdom commands.
+    # the ::xo::tdom classes behave more like plain tDOM commands.
     #
     #my log "tdom AUTO $level [$me autorender]"
 
@@ -124,7 +124,7 @@ namespace eval ::xo::tdom {
   }
 
   #
-  # The tdom attribute manager makes it syntactically easier to
+  # The tDOM attribute manager makes it syntactically easier to
   # specify a list of attributes for rendering via tDOM.
   #
   ::xotcl::Class create ::xo::tdom::AttributeManager
@@ -179,7 +179,7 @@ namespace eval ::xo::tdom {
   
   #
   # ::xo::tdom::Object
-  # is the top of the class hierarchies for tdom objects
+  # is the top of the class hierarchies for tDOM objects
   #
   ::xotcl::Class create ::xo::tdom::Object \
       -superclass {::xo::tdom::AttributeManager ::xo::OrderedComposite} \
@@ -189,6 +189,16 @@ namespace eval ::xo::tdom {
     foreach o [my children] { $o render }
   }
 
+  #
+  # General of HTML markup CSRF tokens in tDOM contexts
+  #
+  namespace eval ::html {}
+  proc ::html::CSRFToken {} {
+    ::if {[::info exists ::__csrf_token]} {
+      ::html::input -type hidden -name __csrf_token -value [::security::csrf::token] {}
+    }
+  }
+
 }
 
 
@@ -206,6 +216,29 @@ namespace eval ::xo {
   # Localization
   #
 
+  #
+  # The following pair of functions implement a crude method for
+  # avoiding i16n substitutions. These are necessary, since xowiki
+  # provides all its markup finally as "content" that is currently
+  # internationalized without distinctions. However, sometimes
+  # (e.g. values in forms) should be presented without i18n
+  # processing. In such cases, the two functions below can be used to
+  # prevent such substitutions.
+  #
+  proc remove_escapes {text} {
+    regsub -all \x01# $text "#" text
+    return $text
+  }
+  
+  proc escape_message_keys {text} {
+    regsub -all {(\#[a-zA-Z0-9_:-]+\.[a-zA-Z0-9_:-]+)\#} $text "\\1\x01#" text
+    return $text
+  }
+
+  #
+  # xo::localize function
+  #
+
   set ::xo::acs_lang_url [apm_package_url_from_key acs-lang]admin
 
   proc localize {text {inline 0}} {
@@ -214,21 +247,21 @@ namespace eval ::xo {
     if {![$obj exists __localizer]} {
       $obj set __localizer [list]
     }
-    if {[string first \x002 $text] == -1} {
+    if {[string first \x02 $text] == -1} {
       return $text
     } else {
       set return_text ""
       if {$inline} {
         # Attempt to move all message keys outside of tags
-        while { [regsub -all {(<[^>]*)(\x002\(\x001[^\x001]*\x001\)\x002)([^>]*>)} $text {\2\1\3} text] } {}
+        while { [regsub -all {(<[^>]*)(\x02\(\x01[^\x01]*\x01\)\x02)([^>]*>)} $text {\2\1\3} text] } {}
         
         # Attempt to move all message keys outside of <select>...</select> statements
-        regsub -all -nocase {(<option\s[^>]*>[^<]*)(\x002\(\x001[^\x001]*\x001\)\x002)([^<]*</option[^>]*>)} $text {\2\1\3} text
+        regsub -all -nocase {(<option\s[^>]*>[^<]*)(\x02\(\x01[^\x01]*\x01\)\x02)([^<]*</option[^>]*>)} $text {\2\1\3} text
         
-        while { [regsub -all -nocase {(<select[^>]*>[^<]*)(\x002\(\x001[^\x001]*\x001\)\x002)} $text {\2\1} text] } {}
+        while { [regsub -all -nocase {(<select[^>]*>[^<]*)(\x02\(\x01[^\x01]*\x01\)\x02)} $text {\2\1} text] } {}
       }
 
-      while {[regexp {^([^\x002]*)\x002\(\x001([^\x001]*)\x001\)\x002(.*)$} $text _ \
+      while {[regexp {^([^\x02]*)\x02\(\x01([^\x01]*)\x01\)\x02(.*)$} $text _ \
                   before key text]} {
         append return_text $before
         lassign [split $key .] package_key message_key
@@ -326,7 +359,7 @@ namespace eval ::xo {
         next
         my render_localizer
       }
-  
+   
   #
   # for the time being, just a proc
   #
@@ -411,7 +444,7 @@ namespace eval ::xo {
     foreach column [[self]::__columns children] {
       if {[$column exists no_csv]} continue
       set label [$column label]
-      if {[regexp {^#(.*)#$} $label _ message_key]} {
+      if {[regexp {^#([a-zA-Z0-9_:-]+\.[a-zA-Z0-9_:-]+)#$} $label _ message_key]} {
         set label [_ $message_key]
       }
       set value [string map {\" \\\" \n \r)} $label]
@@ -605,13 +638,17 @@ namespace eval ::xo::Table {
 
       html::ul -class compact {
         foreach ba $bulkactions {
+          set id [::xowiki::Includelet html_id $ba]
           html::li {
-            html::a -title [$ba tooltip] -class button -href # \
-                -onclick "acs_ListBulkActionClick('$name','[$ba url]'); return false;" \
+            html::a -title [$ba tooltip] -id $id -class button -href # \
                 {
                   html::t [$ba label]
                 }
           }
+          template::add_event_listener \
+              -id $id \
+              -preventdefault=false \
+              -script [subst {acs_ListBulkActionClick('$name','[$ba url]');}]
         }
       }
     }
@@ -794,11 +831,17 @@ namespace eval ::xo::Table {
     set name [my name]
     #my msg [my serialize]
     html::th -class list { 
-      html::input -type checkbox -name __bulkaction \
-          -onclick "acs_ListCheckAll('$name', this.checked)" \
+      html::input -type checkbox -name __bulkaction -id __bulkaction \
           -title "Mark/Unmark all rows"
+      ::html::CSRFToken
     }
+    template::add_body_script -script [subst {
+      document.getElementById('__bulkaction').addEventListener('click', function (event) {
+        acs_ListCheckAll('$name', this.checked);
+      }, false);
+    }]
   }
+  
   TABLE::BulkAction instproc render-data {line} {
     #my msg [my serialize]
     set name [my name]
@@ -921,8 +964,6 @@ namespace eval ::xo {
   #
   # templating and CSS
   #
-  set use_template_head 1
-
   Class create Page
   Page proc requireCSS {{-order 1} name} {
     set ::_xo_need_css($name) [expr {[array size ::_xo_need_css]+1000*$order}]
@@ -935,12 +976,7 @@ namespace eval ::xo {
     set ::_xo_need_js($name)  1
   }
   Page proc requireLink {-rel -type -title -href} {
-    if {$::xo::use_template_head} {
-      template::head::add_link -rel $rel -href $href -type $type -title $title
-    } else {
-      set key "rel='[ns_quotehtml $rel]' type='[ns_quotehtml $type]' title='[ns_quotehtml $title]' href='[ns_quotehtml $href]'"
-      set ::_xo_need_link($key) 1
-    }
+    template::head::add_link -rel $rel -href $href -type $type -title $title
   }
   Page proc set_property {name element value} {
     set ::xo_property_${name}($element) $value
@@ -964,59 +1000,31 @@ namespace eval ::xo {
   }
 
   Page proc header_stuff {} {
-    set result ""
-    if {$::xo::use_template_head} {
-      foreach style [my sort_keys_by_value [array get ::_xo_need_style]] {
-        template::head::add_style -style $style
-      }
-      set count 10
-      foreach file [my sort_keys_by_value [array get ::_xo_need_css]] {
-        template::head::add_css -href $file -media all -order [incr count]
-      }
-      if {[info exists ::_xo_js_order]} {
-        set statements ""
-        set order 10
-        foreach file $::_xo_js_order {
-          if {[string match "*;*" $file]} {
-            # it is not a file, but some javascipt statements
-            #append statements [string map {< "&lt;" > "&gt;"} $file] \n
-            append statements $file \n
-          } else {
-            template::head::add_script -src $file -type text/javascript -order [incr order]
-          }
-        }
-        if {$statements ne ""} {
-          template::head::add_script -script $statements -type text/javascript -order [incr order]
-        }
-      }
 
-      
-    } else {
-      foreach link [array names ::_xo_need_link] {
-        append result "<link $link>\n"
-      }
-      foreach style [my sort_keys_by_value [array get ::_xo_need_style]] {
-        append result "<style type='text/css'>$style</style>\n"
-      }
-      foreach file [my sort_keys_by_value [array get ::_xo_need_css]] {
-        append result "<link type='text/css' rel='stylesheet' href='$file' media='all' >\n"
-      }
-      if {[info exists ::_xo_js_order]} {
-        set statements ""
-        foreach file $::_xo_js_order {
-          if {[string match "*;*" $file]} {
-            # it is not a file, but some javascipt statements
-            append statements $file \n
-          } else {
-            append result "<script src='$file' type='text/javascript'></script>\n"
-          }
-        }
-        if {$statements ne ""} {
-          append result \n "<script type='text/javascript' >$statements</script>\n"
+    foreach style [my sort_keys_by_value [array get ::_xo_need_style]] {
+      template::head::add_style -style $style
+    }
+    set count 10
+    foreach file [my sort_keys_by_value [array get ::_xo_need_css]] {
+      template::head::add_css -href $file -media all -order [incr count]
+    }
+    if {[info exists ::_xo_js_order]} {
+      set statements ""
+      set order 10
+      foreach file $::_xo_js_order {
+        if {[string match "*;*" $file]} {
+          # it is not a file, but some javascipt statements
+          #append statements [string map {< "&lt;" > "&gt;"} $file] \n
+          append statements $file \n
+        } else {
+          template::head::add_script -src $file -type text/javascript -order [incr order]
         }
       }
+      if {$statements ne ""} {
+        template::head::add_script -script $statements -type text/javascript -order [incr order]
+      }
     }
-    return $result
+    return ""
   }
 }
 ::xo::library source_dependent

tcl/40-thread-mod-procs.tcl

@@ -7,16 +7,16 @@ ad_library {
   and destroy threads and to pass commands to these 
   threads. It is designed in a way to create threads
   lazyly such that thread definitions can be included
-  in the modules directory of the aolserver and 
-  therefore be part of the aolserver blueprints.
+  in the modules directory of the AOLserver and 
+  therefore be part of the AOLserver blueprints.
   When an instance of THREAD is created (e.g. t1), 
   an init-command is provided. e.g.:
   <pre>
   ::xotcl::THREAD create t1 {
-    Class Counter -parameter {{value 1}}
+    Class create Counter -parameter {{value 1}}
     Counter instproc ++ {} {my incr value}
-    Counter c1
-    Counter c2
+    Counter create c1
+    Counter create c2
   }
   </pre>
   Commands are sent to the thread via the
@@ -101,7 +101,7 @@ Class create ::xotcl::THREAD \
     -parameter {
       {persistent 0}
       {lightweight 0}
-      {exithandler {my log "EXITHANDLER of slave thread SELF [pid]"}}
+      {exithandler {ns_log notice "EXITHANDLER of slave thread SELF [pid]"}}
     }
 
 ::xotcl::THREAD instproc check_blueprint {} {
@@ -253,16 +253,16 @@ Class create ::xotcl::THREAD \
 # create a sample persistent thread that can be acessed 
 # via request threads
 #::xotcl::THREAD create t0 {
-#  Class Counter -parameter {{value 1}}
+#  Class create Counter -parameter {{value 1}}
 #  Counter instproc ++ {} {my incr value}
 #  
-#  Counter c1
-#  Counter c2
+#  Counter create c1
+#  Counter create c2
 #} -persistent 1
 #
 
 ################## forwarding  proxy ##################
-# Class ::xotcl::THREAD::Proxy -parameter {attach} 
+# Class create ::xotcl::THREAD::Proxy -parameter {attach} 
 # ::xotcl::THREAD::Proxy configure \
     #     -instproc forward args {
 #       set cp [self calledproc]

tcl/50-protocol-handler-procs.tcl

@@ -112,7 +112,7 @@ namespace eval ::xo {
   }
 
   ProtocolHandler ad_instproc register { } {
-    Register the the aolserver filter and traces.
+    Register the the AOLserver filter and traces.
     This method is typically called via *-init.tcl.
 
     Note, that the specified url must not have an entry

tcl/bgdelivery-procs.tcl

@@ -104,7 +104,7 @@ if {![string match "*contentsentlength*" $msg]} {
     unset -nocomplain ::runningBgJob([lindex $::running($key) 0])
     unset ::running($key)
     if {[info exists ::delete_file($key)]} {
-      file delete $filename
+      file delete -- $filename
       unset ::delete_file($key)
     }
   }
@@ -124,7 +124,7 @@ if {![string match "*contentsentlength*" $msg]} {
     }
   }
   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
@@ -204,7 +204,7 @@ if {![string match "*contentsentlength*" $msg]} {
     unset ::running($key)
     unset ::bytes($key)
     if {[info exists ::delete_file($key)]} {
-      file delete $filename
+      file delete -- $filename
       unset ::delete_file($key)
     }
   }
@@ -323,9 +323,12 @@ if {![string match "*contentsentlength*" $msg]} {
   }
 
   Subscriber instproc send {msg} {
+    #ns_log notice "SEND <$msg> [my mode]"
     my log ""
     if {[my mode] eq "scripted"} {
-      set smsg "<script type='text/javascript'>\nvar data = $msg;\n\
+      set emsg [encoding convertto utf-8 $msg]
+      #ns_log notice "SEND data <$msg> encoded <$emsg>"
+      set smsg "<script type='text/javascript' nonce='$::__csp_nonce'>\nvar data = $emsg;\n\
             parent.getData(data);</script>\n"
       set smsg [format %x [string length $smsg]]\r\n$smsg\r\n
     } else {
@@ -344,7 +347,7 @@ if {![string match "*contentsentlength*" $msg]} {
       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
@@ -376,17 +379,17 @@ if {![string match "*contentsentlength*" $msg]} {
     fconfigure [my channel] -translation binary
 
     if {[my mode] eq "scripted"} {
-      set content_type text/html
+      set content_type "text/html;chartype=utf-8"
       set encoding "Cache-Control: no-cache\r\nTransfer-Encoding: chunked\r\n"
       set body "<html><body>[string repeat { } 1024]\r\n"
       set body [format %x [string length $body]]\r\n$body\r\n
     } else {
-      #set content_type text/plain 
       # Chrome refuses to expose partial response to ajax unless we
-      # set content_type to octet stream.  Drawback is we now need to
-      # treat special characters on the client side.
+      # set content_type to octet stream.  Drawback is we have to
+      # force the translation on the channel.
       set content_type "application/octet-stream"
       set encoding ""
+      fconfigure [my channel] -encoding utf-8
       set body ""
     }
 
@@ -630,7 +633,7 @@ bgdelivery ad_proc returnfile {
     if {$bytes == 0} {
       # Tcl behaves different, when one tries to send 0 bytes via
       # file_copy. So, we handle this special case here...
-      # There is actualy nothing to deliver....
+      # There is actually nothing to deliver....
       ns_set put [ns_conn outputheaders] "Content-Length" 0
       ns_return 200 $mime_type {}
       return

tcl/cluster-init.tcl

@@ -28,7 +28,7 @@ if {[server_cluster_enabled_p]} {
   if {$node(url) ne "/"} {
     ns_log notice "***\n*** WARNING: there appears a package mounted on\
        $url\n***Cluster configuration will not work\
-       since there is a conflict with the aolserver filter with the same name!\n"
+       since there is a conflict with the AOLserver filter with the same name!\n"
   }
   
   #ns_register_filter trace GET $url ::xo::Cluster

tcl/cluster-procs.tcl

@@ -21,7 +21,7 @@ namespace eval ::xo {
     foreach n [ns_cache names $cache $pattern] {ns_cache flush $cache $n}
   }
 
-  Class Cluster -parameter {host {port 80}}
+  Class create Cluster -parameter {host {port 80}}
   Cluster set allowed_host_patterns [list]
   Cluster set url /xotcl-cluster-do 
   Cluster array set allowed_host {

tcl/context-procs.tcl

@@ -12,7 +12,7 @@ ad_library {
 
 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 @@ namespace eval ::xo {
     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 ""}} {
@@ -107,7 +108,10 @@ namespace eval ::xo {
     }
     
     #my log "--cc calling parser eval [self] __parse $parse_args"
-    [self] __parse {*}$parse_args
+    if {[catch {[self] __parse {*}$parse_args} errorMsg]} {
+      ad_return_complaint 1 [ns_quotehtml $errorMsg]
+      ad_script_abort
+    }
     #my msg "--cc qp [array get queryparm] // $actual_query"
   }
 
@@ -181,7 +185,7 @@ namespace eval ::xo {
   # ConnectionContext, a context with user and url-specific information
   #
 
-  Class ConnectionContext -superclass Context -parameter {
+  Class create ConnectionContext -superclass Context -parameter {
     user_id
     requestor
     user
@@ -361,7 +365,8 @@ namespace eval ::xo {
       set requestor $pa
       set user "client from $pa"
     } else {
-      set user "<a href='/acs-admin/users/one?user_id=$requestor'>$requestor</a>"
+      set user_url [acs_community_member_admin_url -user_id $requestor]
+      set user "<a href='$user_url'>$requestor</a>"
     }
     #my log "--i requestor = $requestor"
     
@@ -541,7 +546,7 @@ namespace eval ::xo {
   
   proc ::xo::update_query_variable {old_query var value} {
     #
-    # Replace in a url-query old occurances of var with new value.
+    # Replace in a url-query old occurrences of var with new value.
     #
     # @return pairs in a form suitable for export_vars
     #
@@ -559,7 +564,7 @@ namespace eval ::xo {
 
   proc ::xo::update_query {old_query var value} {
     #
-    # Replace in a url-query old occurances of var with new value.
+    # Replace in a url-query old occurrences of var with new value.
     #
     # @return encoded HTTP query
     #

tcl/doc-procs.tcl

 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 @@ namespace eval ::xo {
 	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 @@ namespace eval ::xo {
 	    }
 	}
 	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 @@ namespace eval ::xo {
 	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"
-		}
-	    }
-	}
-	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]
-	    #}
-
-	    foreach mixin $m {
-		if {$mixin ni $things} {lappend mclasses $mixin}
-		append instmixins "[dotquote $e]->[dotquotel $mixin];\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 {![::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 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 mixin $m {
+                if {$mixin ni $things} {lappend mclasses $mixin}
+                append instmixins "[dotquote $e]->[dotquotel $mixin];\n"
+            }
+        }
 
-	#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
+        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
 
-	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 @@ namespace eval ::xo {
 
 # Local variables:
 #    mode: tcl
-#    tcl-indent-level: 2
+#    tcl-indent-level: 4
 #    indent-tabs-mode: nil
 # End:

tcl/html-procs.tcl

@@ -8,7 +8,7 @@ proc require_html_procs {} {
       # set taken from W3C on http://www.w3.org/TR/html4/index/elements.html
       #
 
-      # If the following flag is set to false, tdom makes no checks
+      # If the following flag is set to false, tDOM makes no checks
       # for valid XML character encodings. In particular, XML does not
       # allow characters below 0x20 besides #x9 | #xA | #xD (see XML
       # 1.0 fourth edition http://www.w3.org/TR/REC-xml/) although
@@ -16,13 +16,13 @@ proc require_html_procs {} {
       # other words, XML does not accept all valid UTF-8 strings. HTML
       # does not seem to have this limitation.
       #
-      # CAUTION: Notice that when this flag is set, tdom accepts
-      # invalid XML characters even in XML documents.  If the tdom
+      # CAUTION: Notice that when this flag is set, tDOM accepts
+      # invalid XML characters even in XML documents.  If the tDOM
       # tree is generated in XML and send to a different parser, a
       # thorough XML parser will reject the document. So, this flag
       # has to be used with caution.
       #
-      # However, when the flag is not set, tdom complains about
+      # However, when the flag is not set, tDOM complains about
       # invalid input, so it would be necessary to strip all invalid
       # XML characters via string map etc., which is not nice
       # in the code and bad performance wise.
@@ -30,7 +30,7 @@ proc require_html_procs {} {
       dom setTextCheck false
 
       #
-      # Miscelaneous commands. Not part of html specs
+      # Miscellaneous commands. Not part of html specs
       # but needed for generation of special dom nodes.
       #
 
@@ -46,7 +46,7 @@ proc require_html_procs {} {
       #
       #    -option   name of HTML attribute
       #     value    attribute value
-      #     script   tcl script to run in command's context.
+      #     script   Tcl script to run in command's context.
       #
       # Example: table -border 1 {...}
       #

tcl/http-client-procs.tcl

@@ -462,7 +462,7 @@ namespace eval ::xo {
   # Synchronous (blocking) requests
   #
 
-  Class HttpRequest -superclass HttpCore -slots {
+  Class create HttpRequest -superclass HttpCore -slots {
     Attribute create timeout -type integer
   }
 
@@ -530,7 +530,7 @@ namespace eval ::xo {
   # Asynchronous (non-blocking) requests
   #
 
-  Class AsyncHttpRequest -superclass HttpCore -slots {
+  Class create AsyncHttpRequest -superclass HttpCore -slots {
     Attribute create timeout -type integer -default 10000 ;# 10 seconds
     Attribute create request_manager
   }
@@ -671,13 +671,13 @@ namespace eval ::xo {
       } -instproc success {payload obj} {
         my debug "[string length $payload] bytes payload"
         #if {[string length $payload]<600} {my log payload=$payload}
-        # this is called as after a succesful request
+        # this is called as after a successful request
         my finalize $obj "JOB_COMPLETED" $payload
 
       } -instproc failure {reason obj} {
         my log "[self proc] [self args]"
         my log "failed for '$reason'"
-        # this is called as after an unsuccesful request
+        # this is called as after an unsuccessful request
         my finalize $obj "JOB_FAILED" $reason
 
       } -instproc unknown {method args} {
@@ -752,7 +752,7 @@ namespace eval ::xo {
   # - http://wp.netscape.com/eng/ssl3/3-SPEC.HTM
   # - - - - - - - - - - - - - - - - - - 
   
-  Class Tls
+  Class create Tls
   Tls instproc open_connection {} {
     my instvar S
     #
@@ -770,7 +770,7 @@ namespace eval ::xo {
   # Trace Requests
   #                                 
 
-  Class HttpRequestTrace 
+  Class create HttpRequestTrace 
   nsv_set HttpRequestTrace count 0
 
   HttpRequestTrace instproc init {} {

tcl/install-check-procs.tcl

@@ -40,7 +40,7 @@ namespace eval ::xotcl-core {
       } {
         if {[file exists $dir/$file]} {
           ns_log notice "Deleting obsolete file $dir/$file"
-          file delete $dir/$file
+          file delete -- $dir/$file
         }
       }
     }

tcl/policy-procs.tcl

@@ -8,7 +8,7 @@ ad_library {
 
 namespace eval ::xo {
   
-  Class Policy
+  Class create Policy
 
   Policy instproc defined_methods {class} {
     set c [self]::$class
@@ -139,7 +139,8 @@ namespace eval ::xo {
       set ctx [::xo::Context new -destroy_on_cleanup -actual_query $query]
       $ctx process_query_parameter
     }
-
+    
+    set allowed 0
     set permission [my get_permission $object $method]
     #my log "--permission for o=$object, m=$method => $permission"
 
@@ -148,19 +149,18 @@ namespace eval ::xo {
       lassign [my get_privilege -query_context $ctx $permission $object $method] kind p
       #my msg "--privilege = $p kind = $kind"
       switch -- $kind {
-        primitive {return [my check_privilege -login false \
-                               -package_id $package_id -user_id $user_id \
-                               $p $object $method]}
+        primitive {set allowed [my check_privilege -login false \
+                                    -package_id $package_id -user_id $user_id \
+                                    $p $object $method]}
         complex {
           lassign $p attribute privilege
           set id [$object set $attribute]
-          #my msg "--p checking permission -object_id /$id/ -privilege $privilege -party_id $user_id\
-              #    ==> [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id]"
-          return [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id]
+          set allowed [::xo::cc permission -object_id $id -privilege $privilege -party_id $user_id]
         }
       }
     }
-    return 0
+    #my log "--p check_permissions {$object $method} : $permission ==> $allowed"
+    return $allowed
   }
 
   Policy ad_instproc enforce_permissions {-user_id -package_id object method} {

www/show-class-graph.tcl

@@ -28,10 +28,10 @@ set f [open $tmpnam.$format w]; puts $f $dot_code; close $f
 #ns_log notice "png $tmpnam dot $tmpnam.dot"
 set f [open "|$dot  -T$format -o $tmpfile" w]; puts $f $dot_code; close $f
 ns_returnfile 200 [ns_guesstype $tmpfile] $tmpfile
-file delete $tmpfile
+file delete -- $tmpfile
 
 #set f [open $tmpnam.dot w]; puts $f $dot_code; close $f
-#file delete $tmpnam.dot
+#file delete -- $tmpnam.dot
 
 
 #