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 -r1.35 -r1.36 --- openacs-4/packages/acs-tcl/tcl/apm-file-procs.tcl 24 Dec 2008 00:20:46 -0000 1.35 +++ openacs-4/packages/acs-tcl/tcl/apm-file-procs.tcl 27 Oct 2014 16:40:05 -0000 1.36 @@ -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 } @@ -32,11 +32,11 @@ Return the path to the apm-workspace, creating the directory if necessary. } { - set path [file join [acs_root_dir] apm-workspace] + 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] } } @@ -107,9 +107,7 @@ ad_proc -public apm_package_info_file_path { - { - -path "" - } + {-path ""} package_key } { @@ -119,14 +117,14 @@ } { if { $path eq "" } { - set path "[acs_package_root_dir $package_key]/$package_key.info" + set path [acs_package_root_dir $package_key] } else { - set path "$path/$package_key/$package_key.info" + set path $path/$package_key } - if { [file exists $path] } { - return $path + if { [file exists $path/$package_key.info] } { + return $path/$package_key.info } - error "The $path/$package_key does not contain a package specification file ($package_key.info)." + error "The directory $path does not contain a package specification file ($package_key.info)." } @@ -138,15 +136,15 @@ } { - set apm_file [ns_tmpnam] + set apm_file [ad_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 @@ -165,32 +163,32 @@ } { set package_key [apm_package_key_from_version_id $version_id] set files [apm_get_package_files -all_db_types -package_key $package_key] - set tmpfile [ns_tmpnam] + set tmpfile [ad_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_root_dir]/packages). + # 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_root_dir]/packages" - lappend cmd "$package_key/$file" + lappend cmd -C "$::acs::rootdir/packages" + lappend cmd "$package_key/$file" } lappend cmd "|" [apm_gzip_cmd] -c ">" $tmpfile - eval $cmd + {*}$cmd # At this point, the APM tarball is sitting in $tmpfile. Save it in # the database. @@ -224,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. @@ -250,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 } @@ -274,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). @@ -284,26 +282,26 @@ global apm_current_package_key foreach file_info $files { - util_unlist $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_root_dir]/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_root_dir]/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 } @@ -349,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 @@ -360,7 +358,7 @@ # The apm_guess procs need package_key and a path relative to package root # so parse those out of the given path if { [regexp {^packages/([^/]+)/(.*)$} $path match package_key package_rel_path] } { - if { ![file exists "[acs_root_dir]/$path"] } { + if { ![file exists "$::acs::rootdir/$path"] } { error "apm_file_watchable_p: path $path does not correspond to an existing file" } } else { @@ -370,14 +368,14 @@ # 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] # I would like to add test_procs to the list but currently test_procs files are used to register test cases # and we don't want to resource these files in every interpreter. Test procs should be defined in test_init files. set watchable_file_types [list tcl_procs query_file test_procs] - set right_file_type_p [expr {[lsearch -exact $watchable_file_types $file_type] != -1}] + set right_file_type_p [expr {$file_type in $watchable_file_types}] # Both db type and file type must be right set watchable_p [expr {$right_db_type_p && $right_file_type_p}] @@ -424,7 +422,7 @@ } { set watchable_files [list] - set files [ad_find_all_files [acs_root_dir]/packages/$package_key] + set files [ad_find_all_files $::acs::rootdir/packages/$package_key] foreach file [lsort $files] { set rel_path [ad_make_relative_path $file] if { [apm_file_watchable_p $rel_path] } { @@ -435,9 +433,10 @@ return $watchable_files } -ad_proc -public pkg_home {package_key} { +ad_proc -public -deprecated pkg_home {package_key} { @return A server-root relative path to the directory for a package. Usually /packages/package-key + @see acs_package_root_dir } { return "/packages/$package_key" @@ -450,16 +449,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 } @@ -468,7 +467,7 @@ ad_proc -private apm_tar_cmd {} { @return A valid pointer to tar, 0 otherwise. - + } { return tar } @@ -477,66 +476,88 @@ 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 if the optional xotcl-core components - # are available... - # - if {[info command ::xo::HttpRequest] ne ""} { - # - # ... use xo::HttpRequest... # - #ns_log notice "Transfer $url based to $output_file_name on ::xo::HttpRequest" + # The original solution using ns_httpopen + file_copy does not work + # reliably under windows, for unknown reasons the downloaded file is + # truncated. # - 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 ""} { + # Therefore, we check first for the NaviServer built in ns_http, then + # if the optional xotcl-core components are available... # - # ... if we have 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} + + set httpImpls [util::http::available -url $url -spool] + if {$httpImpls ne ""} { + ns_log notice "we can use the http::util:: interface using the $httpImpls implementation" + set result [util::http::get -url $url -spool] + file rename [dict get $result file] $output_file_name + } elseif {[info commands ::ns_http] ne "" && [apm_version_names_compare [ns_info patchlevel] "4.99.5"] == 1} { + # + # ... 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 to $output_file_name based 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 - } 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 - } + } 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 to $output_file_name 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 to $output_file_name 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 { @@ -550,19 +571,19 @@ @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 if { $url ne "" } { - set file_path [ns_tmpnam].apm + set file_path [ad_tmpnam].apm apm_callback_and_log $callback "
  • Downloading $url..." if { [catch {apm_transfer_file -url $url -output_file_name $file_path} errmsg] } { apm_callback_and_log $callback "Unable to download. Please check your URL.. The following error was returned: 
    [ad_quotehtml $errmsg]
-
    [ad_footer]" + " return - } + } if {![file exists $file_path]} { apm_callback_and_log $callback " @@ -575,47 +596,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 @@ -625,49 +646,56 @@ } apm_callback_and_log $callback "Extracting the .info file ($info_file)..." - set tmpdir [ns_tmpnam] + set tmpdir [ad_tmpnam] file mkdir $tmpdir exec [apm_gzip_cmd] -d -q -c -S .apm $file_path | [apm_tar_cmd] -xf - -C $tmpdir $info_file 2> [apm_dev_null] #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: