Index: openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl,v diff -u -r1.31 -r1.32 --- openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl 12 Aug 2013 19:46:50 -0000 1.31 +++ openacs-4/packages/xowiki/tcl/xowiki-utility-procs.tcl 27 Oct 2014 16:42:06 -0000 1.32 @@ -1,9 +1,10 @@ ::xo::library doc { - XoWiki - Utility procs - @creation-date 2006-08-08 - @author Gustaf Neumann - @cvs-id $Id$ + XoWiki - Utility procs + + @creation-date 2006-08-08 + @author Gustaf Neumann + @cvs-id $Id$ } namespace eval ::xowiki { @@ -38,17 +39,17 @@ ::xotcl::Object create tidy tidy proc clean {text} { if {[[::xo::cc package_id] get_parameter tidy 0] - && [info command ::util::which] ne ""} { + && [info commands ::util::which] ne ""} { set tidycmd [::util::which tidy] if {$tidycmd ne ""} { - set in_file [ns_tmpnam] - ::xowiki::write_file $in_file $text - catch {exec $tidycmd -q -w 0 -ashtml < $in_file 2> /dev/null} output - file delete $in_file - #my msg o=$output - regexp \n(.*)\n $output _ text - #my msg o=$text - return $text + set in_file [ad_tmpnam] + ::xowiki::write_file $in_file $text + catch {exec $tidycmd -q -w 0 -ashtml < $in_file 2> /dev/null} output + file delete $in_file + #my msg o=$output + regexp \n(.*)\n $output _ text + #my msg o=$text + return $text } } return $text @@ -61,10 +62,13 @@ ::xotcl::Object create virus virus proc check {fn} { if {[[::xo::cc package_id] get_parameter clamav 1] - && [info command ::util::which] ne ""} { + && [info commands ::util::which] ne ""} { set clamscanCmd [::util::which clamscan] if {$clamscanCmd ne "" && [file readable $fn]} { - if {[catch {exec $clamscanCmd $fn }]} {return 1} + if {[catch {exec $clamscanCmd $fn 2>@1} result]} { + ns_log warning "[self] virus found:\n$result" + return 1 + } } } return 0 @@ -89,25 +93,25 @@ } ad_proc fix_all_package_ids {} { - earlier versions of openacs did not have the package_id set correctly + Earlier versions of OpenACS did not have the package_id set correctly in acs_objects; this proc updates the package_ids of all items and revisions in acs_objects } { set folder_ids [list] set package_ids [list] foreach package_id [::xowiki::Package instances] { ns_log notice "checking package_id $package_id" - set folder_id [::xo::db_list get_folder_id "select f.folder_id from cr_items c, cr_folders f \ - where c.name = 'xowiki: $package_id' and c.item_id = f.folder_id"] + set folder_id [::xo::dc list get_folder_id "select f.folder_id from cr_items c, cr_folders f \ + where c.name = 'xowiki: :package_id' and c.item_id = f.folder_id"] if {$folder_id ne ""} { db_dml update_package_id {update acs_objects set package_id = :package_id where object_id in - (select item_id as object_id from cr_items where parent_id = :folder_id) + (select item_id as object_id from cr_items where parent_id = :folder_id) and package_id is NULL} db_dml update_package_id {update acs_objects set package_id = :package_id where object_id in - (select r.revision_id as object_id from cr_revisions r, cr_items i where - i.item_id = r.item_id and i.parent_id = :folder_id) + (select r.revision_id as object_id from cr_revisions r, cr_items i where + i.item_id = r.item_id and i.parent_id = :folder_id) and package_id is NULL} } } @@ -127,9 +131,9 @@ set sortkeys "" } ::xo::db::require view xowiki_page_live_revision \ - "select p.*, cr.*,ci.parent_id, ci.name, ci.locale, ci.live_revision, \ - ci.latest_revision, ci.publish_status, ci.content_type, ci.storage_type, \ - ci.storage_area_key $sortkeys \ + "select p.*, cr.*,ci.parent_id, ci.name, ci.locale, ci.live_revision, \ + ci.latest_revision, ci.publish_status, ci.content_type, ci.storage_type, \ + ci.storage_area_key $sortkeys \ from xowiki_page p, cr_items ci, cr_revisions cr \ where p.page_id = ci.live_revision \ and p.page_id = cr.revision_id \ @@ -141,26 +145,26 @@ } { # catch sql statement to allow multiple runs catch {::xo::db::sql::content_type create_attribute \ - -content_type ::xowiki::Page \ - -attribute_name page_order \ - -datatype text \ - -pretty_name Order \ - -column_spec [::xo::db::sql map_datatype ltree]} + -content_type ::xowiki::Page \ + -attribute_name page_order \ + -datatype text \ + -pretty_name Order \ + -column_spec [::xo::dc map_datatype ltree]} ::xo::db::require index -table xowiki_page -col page_order \ - -using [expr {[::xo::db::has_ltree] ? "gist" : ""}] + -using [expr {[::xo::dc has_ltree] ? "gist" : ""}] ::xowiki::update_views return 1 } ad_proc cr_thin_out { - {-doit false} - {-delete_orphans false} - {-delete_sequences false} - {-edit_interval 300} - {-older_than "1 month ago"} - -package_id - -item_id + {-doit false} + {-delete_orphans false} + {-delete_sequences false} + {-edit_interval 300} + {-older_than "1 month ago"} + -package_id + -item_id } { Delete supposedly uninportant items and revision from the content repository. @@ -174,10 +178,10 @@ } { set extra_clause "" if {[info exists package_id]} { - append extra_clause " and o.package_id = $package_id" + append extra_clause " and o.package_id = :package_id" } if {[info exists item_id]} { - append extra_clause " and i.item_id = $item_id" + append extra_clause " and i.item_id = :item_id" } # only delete revisions older than this date @@ -196,16 +200,16 @@ and i.publish_status = 'production' and i.name = r.revision_id::varchar $extra_clause " - foreach tuple [::xo::db_list_of_lists get_revisions $sql] { - #::xotcl::Object msg "tuple = $tuple" - foreach {name package_id item_id revision_id last_modified} $tuple break - set time [clock scan [::xo::db::tcl_date $last_modified tz_var]] - if {$time > $older_than} continue - ::xotcl::Object log "...will delete $name doit=$doit $last_modified" - if {$doit} { - ::xowiki::Package require $package_id - $package_id delete -item_id $item_id -name $name - } + ::xo::dc foreach get_revisions $sql { + #::xotcl::Object msg "tuple = $tuple" + lassign $tuple name package_id item_id revision_id last_modified + set time [clock scan [::xo::db::tcl_date $last_modified tz_var]] + if {$time > $older_than} continue + ::xotcl::Object log "...will delete $name doit=$doit $last_modified" + if {$doit} { + ::xowiki::Package require $package_id + $package_id delete -item_id $item_id -name $name + } } } @@ -227,33 +231,33 @@ set last_user "" set last_revision "" - foreach tuple [::xo::db_list_of_lists get_revisions $sql] { - #::xotcl::Object msg "tuple = $tuple" - foreach {name item_id revision_id last_modified user package_id} $tuple break - set time [clock scan [::xo::db::tcl_date $last_modified tz_var]] - if {$time > $older_than} continue - #::xotcl::Object msg "compare time $time with $older_than => [expr {$time < $older_than}]" - if {$last_user eq $user && $last_item == $item_id} { - set timediff [expr {$time-$last_time}] - #::xotcl::Object msg " timediff=[expr {$time-$last_time}]" - if {$timediff < $edit_interval && $timediff >= 0} { - ::xotcl::Object log "...will delete $name revision=$last_revision, doit=$doit $last_modified" - if {$doit} { - ::xowiki::Package require $package_id - $package_id delete_revision -revision_id $last_revision -item_id $item_id - } - } - } - set last_user $user - set last_time $time - set last_item $item_id - set last_revision $revision_id + xo::dc foreach get_revisions $sql { + #::xotcl::Object msg "tuple = $tuple" + lassign $tuple name item_id revision_id last_modified user package_id + set time [clock scan [::xo::db::tcl_date $last_modified tz_var]] + if {$time > $older_than} continue + #::xotcl::Object msg "compare time $time with $older_than => [expr {$time < $older_than}]" + if {$last_user eq $user && $last_item == $item_id} { + set timediff [expr {$time-$last_time}] + #::xotcl::Object msg " timediff=[expr {$time-$last_time}]" + if {$timediff < $edit_interval && $timediff >= 0} { + ::xotcl::Object log "...will delete $name revision=$last_revision, doit=$doit $last_modified" + if {$doit} { + ::xowiki::Package require $package_id + $package_id delete_revision -revision_id $last_revision -item_id $item_id + } + } + } + set last_user $user + set last_time $time + set last_item $item_id + set last_revision $revision_id } } } proc unmounted_instances {} { - return [::xo::db_list unmounted_instances { + return [::xo::dc list unmounted_instances { select package_id from apm_packages p where not exists (select 1 from site_nodes where object_id = p.package_id) and p.package_key = 'xowiki' @@ -282,12 +286,12 @@ } proc ::xowiki::page_order_uses_ltree {} { - if {[::xo::db::has_ltree]} { + if {[::xo::dc has_ltree]} { ns_cache eval xotcl_object_cache ::xowiki::page_order_uses_ltree { - return [::xo::db_string check_po_ltree { - select count(*) from pg_attribute a, pg_type t, pg_class c - where attname = 'page_order' and a.atttypid = t.oid and c.oid = a.attrelid - and relname = 'xowiki_page'}] + return [::xo::dc get_value check_po_ltree { + select count(*) from pg_attribute a, pg_type t, pg_class c + where attname = 'page_order' and a.atttypid = t.oid and c.oid = a.attrelid + and relname = 'xowiki_page'}] } } else { return 0 @@ -301,7 +305,7 @@ ::xo::clusterwide ns_cache flush xotcl_object_type_cache $item_id set form_id [::xowiki::Weblog instantiate_forms -forms en:folder.form -package_id $package_id] - if {[::xo::db_0or1row check { + if {[::xo::dc 0or1row check { select 1 from cr_items where content_type = '::xowiki::FormPage' and item_id = :item_id }]} { ns_log notice "folder $item_id is already converted" @@ -319,9 +323,9 @@ db_dml chg2 "insert into xowiki_page_instance (page_instance_id, page_template) values ($revision_id, $form_id)" db_dml chg3 "insert into xowiki_form_page (xowiki_form_page_id) values ($revision_id)" - db_dml chg4 "update acs_objects set object_type = 'content_item' where object_id = $item_id" - db_dml chg5 "update acs_objects set object_type = '::xowiki::FormPage' where object_id = $revision_id" - db_dml chg6 "update cr_items set content_type = '::xowiki::FormPage', publish_status = 'ready', live_revision = $revision_id, latest_revision = $revision_id where item_id = $item_id" + db_dml chg4 "update acs_objects set object_type = 'content_item' where object_id = :item_id" + db_dml chg5 "update acs_objects set object_type = '::xowiki::FormPage' where object_id = :revision_id" + db_dml chg6 "update cr_items set content_type = '::xowiki::FormPage', publish_status = 'ready', live_revision = :revision_id, latest_revision = :revision_id where item_id = :item_id" } ad_proc -public -callback subsite::url -impl apm_package { @@ -440,7 +444,8 @@ ::xo::Module create ::xowiki::utility -eval { my proc incr_page_order {p} { - regexp {^(.*[.]?)([^.])$} $p _ prefix suffix + lassign [list "" $p] prefix suffix + regexp {^(.*[.])([^.]+)$} $p _ prefix suffix if {[string is integer -strict $suffix]} { incr suffix } elseif {[string is lower -strict $suffix]} { @@ -471,7 +476,7 @@ return $pairs } - my proc get_page_order_items {-parent_id page_orders} { + my proc get_page_order_items {-parent_id {-publish_status "production"} page_orders} { set likes [list] foreach page_order $page_orders { if {[::xowiki::page_order_uses_ltree]} { @@ -484,22 +489,28 @@ from xowiki_page p, cr_items ci, cr_revisions cr \ where p.page_id = ci.live_revision \ and p.page_id = cr.revision_id \ - and ci.publish_status <> 'production' \ + [::xowiki::Includelet publish_status_clause $publish_status] \ and ci.parent_id = $parent_id \ and ([join $likes { or }])" #my log $sql - set pages [::xo::db_list_of_lists get_pages_with_page_order $sql] + set pages [::xo::dc list_of_lists get_pages_with_page_order $sql] return $pages } - ::xowiki::utility proc page_order_renames {-parent_id -start -from -to} { - set pages [my get_page_order_items -parent_id $parent_id $to] + ::xowiki::utility proc page_order_renames { + -parent_id + {-publish_status "production"} + -start + -from + -to + } { + set pages [my get_page_order_items -parent_id $parent_id -publish_status $publish_status $to] #my log "pages=$pages" array set npo [::xowiki::utility page_order_compute_new_names $start $to] #my log npo=[array get npo]=>to='$to' set renames [list] foreach tuple $pages { - foreach {old_page_order page_id item_id name} $tuple break + lassign $tuple old_page_order page_id item_id name if {[info exists npo($old_page_order)]} { # # We have a name in the translation list @@ -568,31 +579,31 @@ # -gustaf neumann (nov 2010) if {[ns_info name] eq "NaviServer"} { - my proc urlencode {string} {ns_urlencode $string} + my proc urlencode {string} {ns_urlencode $string} } else { - set ue_map [list] - for {set i 0} {$i < 256} {incr i} { - set c [format %c $i] - set x %[format %02x $i] - if {![string match {[-a-zA-Z0-9_.]} $c]} { - lappend ue_map $c $x - } + set ue_map [list] + for {set i 0} {$i < 256} {incr i} { + set c [format %c $i] + set x %[format %02x $i] + if {![string match {[-a-zA-Z0-9_.]} $c]} { + lappend ue_map $c $x } - my proc urlencode {string} {string map [my set ue_map] $string} + } + my proc urlencode {string} {string map [my set ue_map] $string} } my ad_proc user_is_active {{-asHTML:boolean false} uid} { } { - if {[info command ::throttle] ne "" && - [::throttle info methods user_is_active] ne ""} { + if {[info commands ::throttle] ne "" && + [::throttle info methods user_is_active] ne ""} { set active [throttle user_is_active $uid] if {$asHTML} { - array set color {1 green 0 red} - array set state {1 active 0 inactive} - return " " + array set color {1 green 0 red} + array set state {1 active 0 inactive} + return " " } else { - return $active + return $active } } else { ns_log notice "user_is_active requires xotcl-request monitor in a recent version" @@ -695,12 +706,12 @@ # would give us trouble - we choose to ignore text nodes # in this case if { ${nodeType} eq "\#text" && [llength $inner_spec] == 1 } { - # text node - lassign [lindex $inner_spec 0] _nodeType_ text - append json ",'html':[util_jsquotevalue $text]" + # text node + lassign [lindex $inner_spec 0] _nodeType_ text + append json ",'html':[util_jsquotevalue $text]" } else { - # list of children nodes - append json ",'children':\[[util_spec2json $inner_spec]\]" + # list of children nodes + append json ",'children':\[[util_spec2json $inner_spec]\]" } } append json "\}" @@ -716,4 +727,10 @@ return [$root asList] } -::xo::library source_dependent \ No newline at end of file +::xo::library source_dependent +# +# Local variables: +# mode: tcl +# tcl-indent-level: 2 +# indent-tabs-mode: nil +# End: