Index: openacs-4/packages/acs-tcl/tcl/apm-file-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/apm-file-procs.tcl,v diff -u -N -r1.35.8.10 -r1.35.8.11 --- openacs-4/packages/acs-tcl/tcl/apm-file-procs.tcl 16 Oct 2013 19:49:09 -0000 1.35.8.10 +++ openacs-4/packages/acs-tcl/tcl/apm-file-procs.tcl 31 Mar 2014 13:11:08 -0000 1.35.8.11 @@ -14,15 +14,15 @@ } { if { [catch { - file mkdir $path + file mkdir $path }] } { - # There must be a file blocking the directory creation. - if { [catch { - file delete -force $path - file mkdir $path - } errmsg]} { - error "Error creationg directory $path: $errmsg" - } + # There must be a file blocking the directory creation. + if { [catch { + file delete -force $path + file mkdir $path + } errmsg]} { + error "Error creationg directory $path: $errmsg" + } } return $path } @@ -34,9 +34,9 @@ } { set path [file join $::acs::rootdir apm-workspace] if { [file isdirectory $path] } { - return $path + return $path } else { - return [apm_mkdir $path] + return [apm_mkdir $path] } } @@ -48,9 +48,9 @@ set base_path [apm_workspace_dir] set install_path "$base_path/install" if { [file isdirectory $install_path] } { - return $install_path + return $install_path } else { - return [apm_mkdir $install_path] + return [apm_mkdir $install_path] } } @@ -117,12 +117,12 @@ } { if { $path eq "" } { - set path "[acs_package_root_dir $package_key]/$package_key.info" + set path "[acs_package_root_dir $package_key]/$package_key.info" } else { - set path "$path/$package_key/$package_key.info" + set path "$path/$package_key/$package_key.info" } if { [file exists $path] } { - return $path + return $path } error "The $path/$package_key does not contain a package specification file ($package_key.info)." } @@ -139,12 +139,12 @@ set apm_file [ns_tmpnam] db_blob_get_file distribution_tar_ball_select { - select content - from cr_revisions - where revision_id = (select content_item.get_latest_revision(item_id) - from apm_package_versions - where version_id = :version_id) - } $apm_file + select content + from cr_revisions + where revision_id = (select content_item.get_latest_revision(item_id) + from apm_package_versions + where version_id = :version_id) + } $apm_file file mkdir $dir # avoid chdir @@ -166,25 +166,25 @@ set tmpfile [ns_tmpnam] db_1row package_key_select { - select package_key - from apm_package_version_info - where version_id = :version_id - } + select package_key + from apm_package_version_info + where version_id = :version_id + } # Generate a command like: # # tar cf - -C /web/arsdigita/packages acs-kernel/00-proc-procs.tcl \ - # -C /web/arsdigita/packages 10-database-procs.tcl ... \ - # | gzip -c > $tmpfile + # -C /web/arsdigita/packages 10-database-procs.tcl ... \ + # | gzip -c > $tmpfile # # Note that -C changes the working directory before compressing the next # file; we need this to ensure that the tarballs are relative to the # package root directory ($::acs::rootdir/packages). set cmd [list exec [apm_tar_cmd] cf - 2> [apm_dev_null]] foreach file $files { - lappend cmd -C "$::acs::rootdir/packages" - lappend cmd "$package_key/$file" + lappend cmd -C "$::acs::rootdir/packages" + lappend cmd "$package_key/$file" } lappend cmd "|" [apm_gzip_cmd] -c ">" $tmpfile @@ -222,11 +222,11 @@ end;" db_1row item_exists_p {select case when item_id is null - then 0 - else item_id - end as item_id - from apm_package_versions - where version_id = :version_id} + then 0 + else item_id + end as item_id + from apm_package_versions + where version_id = :version_id} if {!$item_id} { # content item hasen't been created yet - create one. @@ -248,17 +248,17 @@ } db_dml update_tarball {update cr_revisions - set content = empty_blob() - where revision_id = :revision_id - returning content into :1} -blob_files [list $tmpfile] + set content = empty_blob() + where revision_id = :revision_id + returning content into :1} -blob_files [list $tmpfile] db_dml update_content_length { - update apm_package_versions - set content_length = (select dbms_lob.getlength(content) - from cr_revisons - where revision_id = :revision_id) - where version_id = :version_id - } + update apm_package_versions + set content_length = (select dbms_lob.getlength(content) + from cr_revisons + where revision_id = :revision_id) + where version_id = :version_id + } file delete $tmpfile } @@ -272,7 +272,7 @@ Load the set of files into the currently running Tcl interpreter. @param -force_reload Indicates if the file should be loaded even if it \ - is already loaded in the interpreter. + is already loaded in the interpreter. } { # This will be the first time loading for each of these files (since if a # file has already been loaded, we just skip it in the loop below). @@ -282,26 +282,26 @@ global apm_current_package_key foreach file_info $files { - lassign $file_info package_key path + lassign $file_info package_key path - if { $force_reload_p || ![nsv_exists apm_library_mtime packages/$package_key/$path] } { - if { [file exists "$::acs::rootdir/packages/$package_key/$path"] } { - apm_callback_and_log $callback "Loading packages/$package_key/$path..." - set apm_current_package_key $package_key + if { $force_reload_p || ![nsv_exists apm_library_mtime packages/$package_key/$path] } { + if { [file exists "$::acs::rootdir/packages/$package_key/$path"] } { + apm_callback_and_log $callback "Loading packages/$package_key/$path..." + set apm_current_package_key $package_key - apm_source "$::acs::rootdir/packages/$package_key/$path" + apm_source "$::acs::rootdir/packages/$package_key/$path" - # Release outstanding database handles (in case this file - # used the db_* database API and a subsequent one uses - # ns_db). - db_release_unused_handles + # Release outstanding database handles (in case this file + # used the db_* database API and a subsequent one uses + # ns_db). + db_release_unused_handles - apm_callback_and_log $callback "Loaded packages/$package_key/$path." - unset apm_current_package_key - } else { - apm_callback_and_log $callback "Unable to load packages/$package_key/$path - file is marked as contained in a package but is not present in the filesystem" - } - } + apm_callback_and_log $callback "Loaded packages/$package_key/$path." + unset apm_current_package_key + } else { + apm_callback_and_log $callback "Unable to load packages/$package_key/$path - file is marked as contained in a package but is not present in the filesystem" + } + } } unset apm_first_time_loading_p } @@ -347,8 +347,8 @@ @param The path of the file relative to server root @return 1 If file is watchable and 0 otherwise. The proc will throw an error if the - file doesn't exist or if the given path cannot be parsed as a path relative - to server root. + file doesn't exist or if the given path cannot be parsed as a path relative + to server root. @see apm_guess_file_type @see apm_guess_db_type @@ -368,7 +368,7 @@ # Check the db type set file_db_type [apm_guess_db_type $package_key $package_rel_path] set right_db_type_p [expr {$file_db_type eq ""} || \ - [string equal $file_db_type [db_type]]] + [string equal $file_db_type [db_type]]] # Check the file type set file_type [apm_guess_file_type $package_key $package_rel_path] @@ -448,16 +448,16 @@ } { set paths [ad_parameter_all_values_as_list -package_id [ad_acs_kernel_id] SystemCommandPaths acs-kernel] if {$paths eq ""} { - return [list "/usr/local/bin" "/usr/bin" "/bin" "/usr/sbin" "/sbin" "/usr/sbin"] + return [list "/usr/local/bin" "/usr/bin" "/bin" "/usr/sbin" "/sbin" "/usr/sbin"] } else { - return $paths + return $paths } } ad_proc -private apm_gzip_cmd {} { @return A valid pointer to gzip, 0 otherwise. - + } { return gzip } @@ -466,7 +466,7 @@ ad_proc -private apm_tar_cmd {} { @return A valid pointer to tar, 0 otherwise. - + } { return tar } @@ -475,82 +475,82 @@ ad_proc -private apm_dev_null {} { @return null device - + } { - if {$::tcl_platform(platform) ne "windows"} { - return /dev/null - } else { - return nul - } + if {$::tcl_platform(platform) ne "windows"} { + return /dev/null + } else { + return nul + } } ad_proc -private apm_transfer_file { - {-url} - {-output_file_name} + {-url} + {-output_file_name} } { - # - # The original solution using ns_httpopen + file_copy does not work - # reliably under windows, for unknown reasons the downloaded file is - # truncated. - # - # Therefore, we check first for the NaviServer built in ns_http, then - # if the optional xotcl-core components are available... - # - if {[info commands ::ns_http] ne "" && [ns_info patchlevel] > "4.99.5"} { - # - # ... use ns_http when we have a version with the "-file" flag ... # - foreach i {1 2 3} { - ns_log notice "Transfer $url to $output_file_name based on ns_http" - set h [ns_http queue -timeout 60:0 $url] - set replyHeaders [ns_set create] - ns_http wait -file F -headers $replyHeaders -spoolsize 1 $h - if {[file exists $output_file_name]} {file delete $output_file_name} - file rename $F $output_file_name - set location [ns_set iget $replyHeaders location] - if {$location eq ""} break - ns_log notice "Transfer $url redirected to $location ..." - set url $location - } - } elseif {[info commands ::xo::HttpRequest] ne ""} { - # - # ... use xo::HttpRequest... + # The original solution using ns_httpopen + file_copy does not work + # reliably under windows, for unknown reasons the downloaded file is + # truncated. # - #ns_log notice "Transfer $url based to $output_file_name on ::xo::HttpRequest" + # Therefore, we check first for the NaviServer built in ns_http, then + # if the optional xotcl-core components are available... # - set r [::xo::HttpRequest new -url $url] - set fileChan [open $output_file_name w 0640] - fconfigure $fileChan -translation binary -encoding binary - puts -nonewline $fileChan [$r set data] - close $fileChan + if {[info commands ::ns_http] ne "" && [ns_info patchlevel] > "4.99.5"} { + # + # ... use ns_http when we have a version with the "-file" flag ... + # + foreach i {1 2 3} { + ns_log notice "Transfer $url to $output_file_name based on ns_http" + set h [ns_http queue -timeout 60:0 $url] + set replyHeaders [ns_set create] + ns_http wait -file F -headers $replyHeaders -spoolsize 1 $h + if {[file exists $output_file_name]} {file delete $output_file_name} + file rename $F $output_file_name + set location [ns_set iget $replyHeaders location] + if {$location eq ""} break + ns_log notice "Transfer $url redirected to $location ..." + set url $location + } + } elseif {[info commands ::xo::HttpRequest] ne ""} { + # + # ... use xo::HttpRequest... + # + #ns_log notice "Transfer $url based to $output_file_name on ::xo::HttpRequest" + # + set r [::xo::HttpRequest new -url $url] + set fileChan [open $output_file_name w 0640] + fconfigure $fileChan -translation binary -encoding binary + puts -nonewline $fileChan [$r set data] + close $fileChan - } elseif {[set wget [::util::which wget]] ne ""} { - # - # ... if we have no ns_http, no ::xo::* and we have "wget" - # installed, we use it. - # - ns_log notice "Transfer $url based on wget" - catch {exec $wget -O $output_file_name $url} + } elseif {[set wget [::util::which wget]] ne ""} { + # + # ... if we have no ns_http, no ::xo::* and we have "wget" + # installed, we use it. + # + ns_log notice "Transfer $url based on wget" + catch {exec $wget -O $output_file_name $url} - } else { - # - # Everything else failed, fall back to the original solution. - # - ns_log notice "Transfer $url based on ns_httpopen" - # Open a destination file. - set fileChan [open $output_file_name w 0640] - # Open the channel to the server. - set httpChan [lindex [ns_httpopen GET $url] 0] - ns_log Debug "APM: Copying data from $url" - fconfigure $httpChan -encoding binary - fconfigure $fileChan -encoding binary - # Copy the data - fcopy $httpChan $fileChan - # Clean up. - ns_log Debug "APM: Done copying data." - close $httpChan - close $fileChan - } + } else { + # + # Everything else failed, fall back to the original solution. + # + ns_log notice "Transfer $url based on ns_httpopen" + # Open a destination file. + set fileChan [open $output_file_name w 0640] + # Open the channel to the server. + set httpChan [lindex [ns_httpopen GET $url] 0] + ns_log Debug "APM: Copying data from $url" + fconfigure $httpChan -encoding binary + fconfigure $fileChan -encoding binary + # Copy the data + fcopy $httpChan $fileChan + # Clean up. + ns_log Debug "APM: Done copying data." + close $httpChan + close $fileChan + } } ad_proc -private apm_load_apm_file { @@ -564,7 +564,7 @@ @param url If specified, will download the APM file first. @return If successful, a path to the .info file of the package uncompressed - into the apm-workspace directory + into the apm-workspace directory } { # First download the apm file if a URL is provided @@ -576,7 +576,7 @@ The following error was returned: 
[ad_quotehtml $errmsg]
" return - } + } if {![file exists $file_path]} { apm_callback_and_log $callback " @@ -589,47 +589,47 @@ #ns_log notice "*** try to exec [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] tf - 2> [apm_dev_null]" if { [catch { - set files [split [string trim \ - [exec [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] tf - 2> [apm_dev_null]]] "\n"] - apm_callback_and_log $callback "
  • Done. Archive is [format %.1f [expr { [file size $file_path] / 1024.0 }]]KB, with [llength $files] files.
  • " + set files [split [string trim \ + [exec [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] tf - 2> [apm_dev_null]]] "\n"] + apm_callback_and_log $callback "
  • Done. Archive is [format %.1f [expr { [file size $file_path] / 1024.0 }]]KB, with [llength $files] files.
  • " } errmsg] } { - apm_callback_and_log $callback "The follow error occured during the uncompression process: - 
    [ad_quotehtml $errmsg]

    - " + apm_callback_and_log $callback "The follow error occured during the uncompression process: + 
    [ad_quotehtml $errmsg]

    + " global errorInfo ns_log Error "Error loading APM file form url $url: $errmsg\n$errorInfo" - return + return } - + if { [llength $files] == 0 } { - apm_callback_and_log $callback "The archive does not contain any files.\n" + apm_callback_and_log $callback "The archive does not contain any files.\n" ns_log Error "Error loading APM file form url $url: The archive does not contain any files." - return + return } set package_key [lindex [split [lindex $files 0] "/"] 0] # Find that .info file. foreach file $files { - set components [split $file "/"] + set components [split $file "/"] - if {[lindex $components 0] ne $package_key } { - apm_callback_and_log $callback "All files in the archive must be contained in the same directory - (corresponding to the package's key). This is not the case, so the archive is not - a valid APM file.\n" + if {[lindex $components 0] ne $package_key } { + apm_callback_and_log $callback "All files in the archive must be contained in the same directory + (corresponding to the package's key). This is not the case, so the archive is not + a valid APM file.\n" ns_log Error "Error loading APM file form url $url: Invalid APM file. All files in the archive must be contained in the same directory corresponding to the package's key." - return - } - - if { [llength $components] == 2 && [file extension $file] eq ".info" } { - if { [info exists info_file] } { - apm_callback_and_log $callback "The archive contains more than one package/*/*.info file, so it is not a valid APM file.\n" + return + } + + if { [llength $components] == 2 && [file extension $file] eq ".info" } { + if { [info exists info_file] } { + apm_callback_and_log $callback "The archive contains more than one package/*/*.info file, so it is not a valid APM file.\n" ns_log Error "Error loading APM file form url $url: Invalid APM file. More than one package .info file." - return - } else { - set info_file $file - } - } + return + } else { + set info_file $file + } + } } if { ![info exists info_file] || [regexp {[^a-zA-Z0-9\-\./_]} $info_file] } { apm_callback_and_log $callback "The archive does not contain a */*.info file, so it is not @@ -646,42 +646,49 @@ #exec sh -c "cd $tmpdir ; [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] xf - $info_file" 2> [apm_dev_null] if { [catch { - array set package [apm_read_package_info_file [file join $tmpdir $info_file]] + array set package [apm_read_package_info_file [file join $tmpdir $info_file]] } errmsg]} { - file delete -force $tmpdir - apm_callback_and_log $callback "The archive contains an unparseable package specification file: - $info_file. The following error was produced while trying to - parse it: 
    [ad_quotehtml $errmsg]
    . -

    - The package cannot be installed. - \n" + file delete -force $tmpdir + apm_callback_and_log $callback "The archive contains an unparseable package specification file: + $info_file. The following error was produced while trying to + parse it: 

    [ad_quotehtml $errmsg]
    . +

    + The package cannot be installed. + \n" global errorInfo ns_log Error "Error loading APM file form url $url: Bad package .info file. $errmsg\n$errorInfo" - return + return } file delete -force $tmpdir set package_key $package(package.key) set pretty_name $package(package-name) set version_name $package(name) ns_log Debug "APM: Preparing to load $pretty_name $version_name" # Determine if this package version is already installed. - if {[apm_package_version_installed_p $package_key $version_name]} { - apm_callback_and_log $callback "

  • $pretty_name $version_name is already installed in your system." + if {[apm_package_version_installed_p $package_key $version_name]} { + apm_callback_and_log $callback "
  • $pretty_name $version_name is already installed in your system." ns_log Error "Error loading APM file form url $url: Package $pretty_name $version_name is already installed" } else { - - set install_path "[apm_workspace_install_dir]" - - if { ![file isdirectory $install_path] } { - file mkdir $install_path - } - - apm_callback_and_log $callback "
  • Extracting files into the filesytem." - apm_callback_and_log $callback "
  • $pretty_name $version_name ready for installation." + + set install_path "[apm_workspace_install_dir]" + + if { ![file isdirectory $install_path] } { + file mkdir $install_path + } + + apm_callback_and_log $callback "
  • Extracting files into the filesytem." + apm_callback_and_log $callback "
  • $pretty_name $version_name ready for installation." - #ns_log notice "exec sh -c 'cd $install_path ; [apm_gzip_cmd] -d -q -c $file_path | [apm_tar_cmd] xf -' 2>/dev/null" - exec [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] -xf - -C $install_path 2> [apm_dev_null] + #ns_log notice "exec sh -c 'cd $install_path ; [apm_gzip_cmd] -d -q -c $file_path | [apm_tar_cmd] xf -' 2>/dev/null" + exec [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] -xf - -C $install_path 2> [apm_dev_null] return "${install_path}/${package_key}/${package_key}.info" } } + +# +# Local variables: +# mode: tcl +# tcl-indent-level: 4 +# indent-tabs-mode: nil +# End: