Index: openacs-4/packages/acs-tcl/tcl/openacs-kernel-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/openacs-kernel-procs.tcl,v diff -u -N --- openacs-4/packages/acs-tcl/tcl/openacs-kernel-procs.tcl 12 Dec 2019 09:45:45 -0000 1.11.2.3 +++ /dev/null 1 Jan 1970 00:00:00 -0000 @@ -1,178 +0,0 @@ -ad_library { - A library of additional OpenACS utilities - - @author ben@openforce - @creation-date 2002-03-05 - @cvs-id $Id: openacs-kernel-procs.tcl,v 1.11.2.3 2019/12/12 09:45:45 gustafn Exp $ -} - -namespace eval oacs_util {} - -ad_proc -public oacs_util::process_objects_csv { - {-object_type:required} - {-file:required} - {-header_line 1} - {-override_headers {}} - {-constants ""} -} { - This processes a CSV of objects, taking the csv and calling package_instantiate_object - for each one. - - @return a list of the created object_ids -} { - # FIXME: We should catch the error here - set csv_stream [open $file r] - - # Check if there are headers - if {$override_headers ne ""} { - set headers $override_headers - } else { - if {!$header_line} { - return -code error "There is no header!" - } - - # get the headers - ns_getcsv $csv_stream headers - } - - set list_of_object_ids [list] - - # Process the file - db_transaction { - while {1} { - # Get a line - set n_fields [ns_getcsv $csv_stream one_line] - - # end of things - if {$n_fields == -1} { - break - } - - # ignore empty lines - if {$n_fields == 0} { - continue - } - - # Process the row - set extra_vars [ns_set create] - for {set i 0} {$i < $n_fields} {incr i} { - set varname [string tolower [lindex $headers $i]] - set varvalue [lindex $one_line $i] - - # Set the value - ns_log debug "oacs_util::process_objects_csv: setting $varname to $varvalue" - ns_set put $extra_vars $varname $varvalue - } - - # Add in the constants - if {$constants ne ""} { - # This modifies extra_vars, without touching constants - ns_set merge $constants $extra_vars - } - - # Create object and go for it - set object_id [package_instantiate_object -extra_vars $extra_vars $object_type] - lappend list_of_object_ids $object_id - - # Clean Up - ns_set free $extra_vars - } - } - - close $csv_stream - - # Return the list of objects - return $list_of_object_ids -} - -ad_proc -public oacs_util::csv_foreach { - {-file:required} - {-header_line 1} - {-override_headers {}} - {-array_name:required} - code_block -} { - reads a csv and executes code block for each row in the csv. - - @param file the csv file to read. - @param header_line the line with the list of var names - @param override_headers the list of variables in the csv - @param array_name the name of the array to set with the values from the csv as each line is read. -} { - # FIXME: We should catch the error here - set csv_stream [open $file r] - - # Check if there are headers - if {$override_headers ne ""} { - set headers $override_headers - } else { - if {!$header_line} { - return -code error "There is no header!" - } - - # get the headers - ns_getcsv $csv_stream headers - } - - # provide access to errorCode - - # Upvar Magic! - upvar 1 $array_name row_array - - while {1} { - # Get a line - set n_fields [ns_getcsv $csv_stream one_line] - - # end of things - if {$n_fields == -1} { - break - } - - # Process the row - for {set i 0} {$i < $n_fields} {incr i} { - set varname [string tolower [lindex $headers $i]] - set varvalue [lindex $one_line $i] - set row_array($varname) $varvalue - } - - # Now we are ready to process the code block - set errno [catch { uplevel 1 $code_block } error] - - if {$errno > 0} { - close $csv_stream - } - - # handle error, return, break, continue - # (source: https://wiki.tcl-lang.org/unless last case) - switch -exact -- $errno { - 0 {} - 1 {return -code error -errorinfo $::errorInfo \ - -errorcode $::errorCode $error} - 2 {return $error} - 3 {break} - 4 {} - default {return -code $errno $error} - } - } -} - -ad_proc -public oacs_util::vars_to_ns_set { - {-ns_set:required} - {-var_list:required} -} { - Does an ns_set put on each variable named in var_list - - @param var_list list of variable names in the calling scope - @param ns_set an ns_set id that already exists. -} { - foreach var $var_list { - upvar $var one_var - ns_set put $ns_set $var $one_var - } -} - -# Local variables: -# mode: tcl -# tcl-indent-level: 4 -# indent-tabs-mode: nil -# End: Index: openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl,v diff -u -N -r1.189.2.42 -r1.189.2.43 --- openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 11 Dec 2019 18:13:56 -0000 1.189.2.42 +++ openacs-4/packages/acs-tcl/tcl/utilities-procs.tcl 12 Dec 2019 10:00:52 -0000 1.189.2.43 @@ -8,7 +8,16 @@ @cvs-id $Id$ } +# +# Namespace handlig for the utilities is pretty arbitrary. +# We have currently +# - ad_* +# - util_* +# - util::* +# - oacs_util::* +# namespace eval util {} +namespace eval oacs_util {} ad_proc util::pdfinfo { file @@ -1311,7 +1320,169 @@ return $result } +ad_proc -public oacs_util::process_objects_csv { + {-object_type:required} + {-file:required} + {-header_line 1} + {-override_headers {}} + {-constants ""} +} { + This processes a CSV of objects, taking the csv and calling package_instantiate_object + for each one. + @return a list of the created object_ids +} { + # FIXME: We should catch the error here + set csv_stream [open $file r] + + # Check if there are headers + if {$override_headers ne ""} { + set headers $override_headers + } else { + if {!$header_line} { + return -code error "There is no header!" + } + + # get the headers + ns_getcsv $csv_stream headers + } + + set list_of_object_ids [list] + + # Process the file + db_transaction { + while {1} { + # Get a line + set n_fields [ns_getcsv $csv_stream one_line] + + # end of things + if {$n_fields == -1} { + break + } + + # ignore empty lines + if {$n_fields == 0} { + continue + } + + # Process the row + set extra_vars [ns_set create] + for {set i 0} {$i < $n_fields} {incr i} { + set varname [string tolower [lindex $headers $i]] + set varvalue [lindex $one_line $i] + + # Set the value + ns_log debug "oacs_util::process_objects_csv: setting $varname to $varvalue" + ns_set put $extra_vars $varname $varvalue + } + + # Add in the constants + if {$constants ne ""} { + # This modifies extra_vars, without touching constants + ns_set merge $constants $extra_vars + } + + # Create object and go for it + set object_id [package_instantiate_object -extra_vars $extra_vars $object_type] + lappend list_of_object_ids $object_id + + # Clean Up + ns_set free $extra_vars + } + } + + close $csv_stream + + # Return the list of objects + return $list_of_object_ids +} + +ad_proc -public oacs_util::csv_foreach { + {-file:required} + {-header_line 1} + {-override_headers {}} + {-array_name:required} + code_block +} { + reads a csv and executes code block for each row in the csv. + + @param file the csv file to read. + @param header_line the line with the list of var names + @param override_headers the list of variables in the csv + @param array_name the name of the array to set with the values from the csv as each line is read. +} { + # FIXME: We should catch the error here + set csv_stream [open $file r] + + # Check if there are headers + if {$override_headers ne ""} { + set headers $override_headers + } else { + if {!$header_line} { + return -code error "There is no header!" + } + + # get the headers + ns_getcsv $csv_stream headers + } + + # provide access to errorCode + + # Upvar Magic! + upvar 1 $array_name row_array + + while {1} { + # Get a line + set n_fields [ns_getcsv $csv_stream one_line] + + # end of things + if {$n_fields == -1} { + break + } + + # Process the row + for {set i 0} {$i < $n_fields} {incr i} { + set varname [string tolower [lindex $headers $i]] + set varvalue [lindex $one_line $i] + set row_array($varname) $varvalue + } + + # Now we are ready to process the code block + set errno [catch { uplevel 1 $code_block } error] + + if {$errno > 0} { + close $csv_stream + } + + # handle error, return, break, continue + # (source: https://wiki.tcl-lang.org/unless last case) + switch -exact -- $errno { + 0 {} + 1 {return -code error -errorinfo $::errorInfo \ + -errorcode $::errorCode $error} + 2 {return $error} + 3 {break} + 4 {} + default {return -code $errno $error} + } + } +} + +ad_proc -public oacs_util::vars_to_ns_set { + {-ns_set:required} + {-var_list:required} +} { + Does an ns_set put on each variable named in var_list + + @param var_list list of variable names in the calling scope + @param ns_set an ns_set id that already exists. +} { + foreach var $var_list { + upvar $var one_var + ns_set put $ns_set $var $one_var + } +} + ad_proc -private util_WriteWithExtraOutputHeaders { headers_so_far {first_part_of_page ""} @@ -1396,11 +1567,11 @@ } ad_proc -public ad_safe_eval args { - + Version of "eval" that checks its arguments for brackets that may be used to execute unsafe code. There are actually better ways in Tcl to achieve this, but it is kept for backwards compatibility. - + } { foreach arg $args { if { [string match {*[\[;]*} $arg] } {