Index: openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl,v
diff -u -N -r1.47 -r1.48
--- openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl	21 Mar 2013 21:58:05 -0000	1.47
+++ openacs-4/packages/xotcl-core/tcl/bgdelivery-procs.tcl	27 Oct 2014 16:42:01 -0000	1.48
@@ -1,13 +1,13 @@
 ad_library {
 
-    Routines for background delivery of files
+  Routines for background delivery of files
 
-    @author Gustaf Neumann (neumann@wu-wien.ac.at)
-    @creation-date 19 Nov 2005
-    @cvs-id $Id$
+  @author Gustaf Neumann (neumann@wu-wien.ac.at)
+  @creation-date 19 Nov 2005
+  @cvs-id $Id$
 }
 
-if {[info command ::thread::mutex] eq ""} {
+if {[info commands ::thread::mutex] eq ""} {
   ns_log notice "libthread does not appear to be available, NOT loading bgdelivery"
   return
 }
@@ -16,7 +16,7 @@
 # catch {ns_conn contentsentlength} alone does not work, since we do not have
 # a connection yet, and the bgdelivery won't be activated
 catch {ns_conn xxxxx} msg
-if {![string match *contentsentlength* $msg]} {
+if {![string match "*contentsentlength*" $msg]} {
   ns_log notice "AOLserver is not patched for bgdelivery, NOT loading bgdelivery"
 
   ad_proc -public ad_returnfile_background {-client_data status_code mime_type filename} {
@@ -50,7 +50,7 @@
   fileSpooler proc deliver_ranges {ranges client_data filename fd channel} {
     set first_range [lindex $ranges 0]
     set remaining_ranges [lrange $ranges 1 end]
-    foreach {from to size} $first_range break
+    lassign $first_range from to size
     if {$remaining_ranges eq ""} {
       # A single delivery, which is as well the last; when finished
       # with this chunk, terminate delivery
@@ -76,10 +76,10 @@
 
     set k ::runningBgJob([lindex $context 0])
     if {[info exists $k]} {
-	set value [set $k]
-	ns_log notice "resubmit: canceling currently running request $context  // closing $value"
-        lassign $value fd0 channel0 client_data0 filename0
-	my end-delivery -client_data $client_data0 $filename0 $fd0 $channel0 -1 
+      set value [set $k]
+      ns_log notice "resubmit: canceling currently running request $context  // closing $value"
+      lassign $value fd0 channel0 client_data0 filename0
+      my end-delivery -client_data $client_data0 $filename0 $fd0 $channel0 -1 
     }
     set $k [list $fd $channel $client_data $filename]
 
@@ -113,7 +113,7 @@
     # This method should not be necessary. However, under unclear conditions,
     # some fcopies seem to go into a stasis. After 2000 seconds, we will kill it.
     foreach {index entry} [array get ::running] {
-      foreach {key elapsed} $entry break
+      lassign $entry key elapsed
       set t [ns_time diff [ns_time get] $elapsed]
       if {[ns_time seconds $t] > 2000} {
         if {[regexp {^([^,]+),([^,]+),(.+)$} $index _ channel fd filename]} {
@@ -230,11 +230,11 @@
 
   ::AsyncDiskWriter instproc close {{-sync false}} {
     my instvar content channel
-    if {$sync || [string length $content] == 0} {
+    if {$sync || $content eq ""} {
       my log "close sync"
       if {$content ne ""} {
-	fconfigure $channel -translation binary -blocking true
-	puts -nonewline $channel $content
+        fconfigure $channel -translation binary -blocking true
+        puts -nonewline $channel $content
       }
       close $channel
       my destroy
@@ -256,10 +256,10 @@
       set content ""
       if {[my autoflush]} {flush $channel}
       if {[my exists finishWhenDone]} {
-	my close -sync true
+        my close -sync true
       }
     } else {
-      set chunk [string range $content 0 [expr {$blocksize-1}]]
+      set chunk [string range $content 0 $blocksize-1]
       set content [string range $content $blocksize end]
       puts -nonewline $channel $chunk
       my log "write [string length $chunk] bytes ([string length $content] buffered)"
@@ -279,11 +279,11 @@
     set result [list]
     if {[info exists key]} {
       if {[info exists subscriptions($key)]} {
-	return [list $key $subscriptions($key)]
+        return [list $key $subscriptions($key)]
       }
     } elseif {[info exists subscriptions]} {
       foreach key [array names subscriptions] {
-	lappend result $key $subscriptions($key)
+        lappend result $key $subscriptions($key)
       }
     }
   }
@@ -332,7 +332,7 @@
       set smsg $msg
     }
     #my log "-- sending to subscriber for [my key] $smsg ch=[my channel] \
-    #		mode=[my mode], user_id [my user_id]"
+        #        mode=[my mode], user_id [my user_id]"
     puts -nonewline [my channel] $smsg
     flush [my channel]
   }
@@ -343,12 +343,12 @@
     if {[info exists subscriptions($key)]} {
       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"
-	  $s destroy
-	} else {
-	  lappend subs1 $s
-	}
+        if {[catch {$s $method $argument} errMsg]} {
+          ns_log notice "error in $method to subscriber $s (key=$key): $errMsg"
+          $s destroy
+        } else {
+          lappend subs1 $s
+        }
       }
       set subscriptions($key) $subs1
     }
@@ -434,7 +434,7 @@
       set spooling 1
       # puts -nonewline [my channel] $data
       # my done
-      set filename [ns_tmpnam]
+      set filename [ad_tmpnam]
       set fd [open $filename w]
       fconfigure $fd -translation binary -encoding $encoding
       puts -nonewline $fd $data
@@ -443,7 +443,7 @@
       fconfigure $fd -translation binary -encoding $encoding
       fconfigure [my channel] -translation binary  -encoding $encoding
       fcopy $fd [my channel] -command \
-	  [list [self] end-delivery $filename $fd [my channel] $request]
+          [list [self] end-delivery $filename $fd [my channel] $request]
     }
   }
   ::HttpSpooler instproc end-delivery {filename fd ch request bytes args} {
@@ -453,9 +453,7 @@
     my set spooling 0
     if {[llength $queue]>0} {
       my log "--dequeue"
-      set data [lindex $queue 0]
-      set req  [lindex $queue 1]
-      set enc  [lindex $queue 2]
+      lassign $queue data req enc
       set queue [lreplace $queue 0 2]
       my deliver $data $req $enc
     }
@@ -467,8 +465,8 @@
       regexp {^([^:]+):(.*)$} $host _ host port
       my incr running
       xo::AsyncHttpRequest [self]::[my incr counter] \
-	  -host $host -port $port -path $path \
-	  -timeout [my timeout] -post_data $post_data -request_manager [self]
+          -host $host -port $port -path $path \
+          -timeout [my timeout] -post_data $post_data -request_manager [self]
     }
   }
 
@@ -508,182 +506,195 @@
   {-delete false} 
   {-content_disposition} 
   status_code mime_type filename} {
-  Deliver the given file to the requestor in the background. This proc uses the
-  background delivery thread to send the file in an event-driven manner without
-  blocking a request thread. This is especially important when large files are 
-  requested over slow (e.g. dial-ip) connections.
-} {
+    Deliver the given file to the requestor in the background. This proc uses the
+    background delivery thread to send the file in an event-driven manner without
+    blocking a request thread. This is especially important when large files are 
+    requested over slow (e.g. dial-ip) connections.
+  } {
 
-  #ns_setexpires 1000000
-  #ns_log notice "expires-set $filename"
-  #ns_log notice "status_code = $status_code, filename=$filename"
+    #ns_setexpires 1000000
+    #ns_log notice "expires-set $filename"
+    #ns_log notice "status_code = $status_code, filename=$filename"
 
-  if {![my isobject ::xo::cc]} {
-    ::xo::ConnectionContext require
-  }
-  set query [::xo::cc actual_query]
-  set use_h264 [expr {[string match video/mp4* $mime_type] && $query ne "" 
-                      && ([string match {*start=[1-9]*} $query] || [string match {*end=[1-9]*} $query])
-                      && [info command h264open] ne ""}]
+    if {![my isobject ::xo::cc]} {
+      ::xo::ConnectionContext require
+    }
+    set query [::xo::cc actual_query]
+    set use_h264 [expr {[string match "video/mp4*" $mime_type] && $query ne "" 
+                        && ([string match {*start=[1-9]*} $query] || [string match {*end=[1-9]*} $query])
+                        && [info command h264open] ne ""}]
 
-  if {[info command ns_driversection] ne ""} {
+    if {[info commands ns_driversection] ne ""} {
       set use_writerThread [ns_config [ns_driversection] writerthreads 0]
-  } else {
+    } else {
       set use_writerThread 0
-  }
+    }
 
-  if {[info exists content_disposition]} {
-    set fn [xo::backslash_escape \" $content_disposition]
-    ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\""
-  }
+    if {[info exists content_disposition]} {
+      set fn [xo::backslash_escape \" $content_disposition]
+      ns_set put [ns_conn outputheaders] Content-Disposition "attachment;filename=\"$fn\""
+    }
 
-  if {$use_h264} {
-    if {0} {
-      # we have to obtain the size from the file; unfortunately, this
-      # requires a duplicate open+close of the h264 stream. If the
-      # application is performance sensitive, one might consider to use
-      # the possibly incorrect size form the file system instead (works
-      # perfectly for e.g. flowplayer)
-      if {[catch {set handle [h264open $filename $query]} errorMsg]} {
-        ns_log error "h264: error opening h264 channel for $filename $query: $errorMsg"
-        return
+    if {$use_h264} {
+      if {0} {
+        # we have to obtain the size from the file; unfortunately, this
+        # requires a duplicate open+close of the h264 stream. If the
+        # application is performance sensitive, one might consider to use
+        # the possibly incorrect size form the file system instead (works
+        # perfectly for e.g. flowplayer)
+        if {[catch {set handle [h264open $filename $query]} errorMsg]} {
+          ns_log error "h264: error opening h264 channel for $filename $query: $errorMsg"
+          return
+        }
+        set size [h264length $handle]
+        h264close $handle
+      } else {
+        set size [file size $filename]
       }
-      set size [h264length $handle]
-      h264close $handle
     } else {
       set size [file size $filename]
     }
-  } else {
-    set size [file size $filename]
-  }
 
-  # Make sure to set "connection close" for the reqests (in other
-  # words, don't allow keep-alive, which is does not make sense, when
-  # we close the connections manually in the bgdelivery thread).
-  #
-  if {$::xo::naviserver && !$use_writerThread} {
-    ns_conn keepalive 0
-  }
+    # Make sure to set "connection close" for the reqests (in other
+    # words, don't allow keep-alive, which is does not make sense, when
+    # we close the connections manually in the bgdelivery thread).
+    #
+    if {$::xo::naviserver && !$use_writerThread} {
+      ns_conn keepalive 0
+    }
 
-  set range [ns_set iget [ns_conn headers] range]
-  if {[regexp {bytes=(.*)$} $range _ range]} {
-    set ranges [list]
-    set bytes 0
-    set pos 0
-    foreach r [split $range ,] {
-      regexp {^(\d*)-(\d*)$} $r _ from to
-      if {$from eq ""} {
-	# The last $to bytes, $to must be specified; 'to' is
-	# differently interpreted as in the case, where from is
-	# non-empty
-	set from [expr {$size - $to}]
-      } else {
-	if {$to eq ""} {set to [expr {$size-1}]}
+    set range [ns_set iget [ns_conn headers] range]
+    if {[regexp {bytes=(.*)$} $range _ range]} {
+      set ranges [list]
+      set bytes 0
+      set pos 0
+      foreach r [split $range ,] {
+        regexp {^(\d*)-(\d*)$} $r _ from to
+        if {$from eq ""} {
+          # The last $to bytes, $to must be specified; 'to' is
+          # differently interpreted as in the case, where from is
+          # non-empty
+          set from [expr {$size - $to}]
+        } else {
+          if {$to eq ""} {set to [expr {$size-1}]}
+        }
+        set rangeSize [expr {1 + $to - $from}]
+        lappend ranges [list $from $to $rangeSize]
+        set pos [expr {$to + 1}]
+        incr bytes $rangeSize
       }
-      set rangeSize [expr {1 + $to - $from}]
-      lappend ranges [list $from $to $rangeSize]
-      set pos [expr {$to + 1}]
-      incr bytes $rangeSize
+    } else {
+      set ranges ""
+      set bytes $size
     }
-  } else {
-    set ranges ""
-    set bytes $size
-  }
 
-  #ns_log notice "Range=$range bytes=$bytes // $ranges"
+    #ns_log notice "Range=$range bytes=$bytes // $ranges"
 
-  #
-  # For the time being, we write the headers in a simplified version
-  # directly in the spooling thread to avoid the overhead of double
-  # h264opens.
-  #
-  if {!$use_h264} {
     #
-    # Add content-range header for range requests.
+    # For the time being, we write the headers in a simplified version
+    # directly in the spooling thread to avoid the overhead of double
+    # h264opens.
     #
-    if {[llength $ranges] == 1 && $status_code == 200} {
-      lassign [lindex $ranges 0] from to
-      ns_set put [ns_conn outputheaders] Content-Range "bytes $from-$to/$size"
-      ns_log notice "added header-field Content-Range: bytes $from-$to/$size // $ranges"
-      set status_code 206
-    } elseif {[llength $ranges]>1} {
-      ns_log warning "Multiple ranges are currently not supported, ignoring range request"
+    if {!$use_h264} {
+      #
+      # Add content-range header for range requests.
+      #
+      if {[llength $ranges] == 1 && $status_code == 200} {
+        lassign [lindex $ranges 0] from to
+        if {$from <= $to && $size > $to} {
+          ns_set put [ns_conn outputheaders] Content-Range "bytes $from-$to/$size"
+          ns_log notice "given range <$range>, added header-field Content-Range: bytes $from-$to/$size // $ranges"
+          set status_code 206
+        } else {
+          # A byte-content-range-spec with a byte-range-resp-spec whose
+          # last-byte-pos value is less than its first-byte-pos value,
+          # or whose instance-length value is less than or equal to its
+          # last-byte-pos value, is invalid. The recipient of an invalid
+          # byte-content-range-spec MUST ignore it and any content
+          # transferred along with it.
+          #
+          # See http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html (14.16)
+          #
+          ns_log notice "### ignore invalid <$range>, pos > size-1, Content-Range: bytes $from-$to/$size // $ranges"
+        }
+      } elseif {[llength $ranges]>1} {
+        ns_log warning "Multiple ranges are currently not supported, ignoring range request"
+      }
+      my write_headers $status_code $mime_type $bytes
     }
-    my write_headers $status_code $mime_type $bytes
-  }
 
-  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....
-    ns_set put [ns_conn outputheaders] "Content-Length" 0
-    ns_return 200 $mime_type {}
-    return
-  }
+    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....
+      ns_set put [ns_conn outputheaders] "Content-Length" 0
+      ns_return 200 $mime_type {}
+      return
+    }
 
-  if {$use_writerThread && !$use_h264} {
+    if {$use_writerThread && !$use_h264} {
       if {$status_code == 206} {
-	  ns_log notice "ns_writer submitfile -offset $from -size $bytes $filename"
-	  ns_writer submitfile -offset $from -size $bytes $filename
+        ns_log notice "ns_writer submitfile -offset $from -size $bytes $filename"
+        ns_writer submitfile -offset $from -size $bytes $filename
       } else {
-	  ns_log notice "ns_writer submitfile $filename"
-	  ns_writer submitfile $filename
+        ns_log notice "ns_writer submitfile $filename"
+        ns_writer submitfile $filename
       }
       return
-  }
+    }
 
-  set errorMsg ""
-  # Get the thread id and make sure the bgdelivery thread is already
-  # running.
-  set tid [my get_tid]
-  
-  # my log "+++ lock [my set bgmutex]"
-  ::thread::mutex lock [my set mutex]
+    set errorMsg ""
+    # Get the thread id and make sure the bgdelivery thread is already
+    # running.
+    set tid [my get_tid]
+    
+    # my log "+++ lock [my set bgmutex]"
+    ::thread::mutex lock [my set mutex]
 
-  #
-  # Transfer the channel to the bgdelivery thread and report errors
-  # in detail. 
-  #
-  # Notice, that Tcl versions up to 8.5.4 have a bug in this area.
-  # If one uses an earlier version of Tcl, please apply:
-  # http://tcl.cvs.sourceforge.net/viewvc/tcl/tcl/generic/tclIO.c?r1=1.61.2.29&r2=1.61.2.30&pathrev=core-8-4-branch
-  #
+    #
+    # Transfer the channel to the bgdelivery thread and report errors
+    # in detail. 
+    #
+    # Notice, that Tcl versions up to 8.5.4 have a bug in this area.
+    # If one uses an earlier version of Tcl, please apply:
+    # http://tcl.cvs.sourceforge.net/viewvc/tcl/tcl/generic/tclIO.c?r1=1.61.2.29&r2=1.61.2.30&pathrev=core-8-4-branch
+    #
 
-  catch {
-    set ch [ns_conn channel]
-    if {[catch {thread::transfer $tid $ch} innerError]} {
-      set channels_in_use "??"
-      catch {set channels_in_use [bgdelivery do file channels]}
-      ns_log error "thread transfer failed, channel=$ch, channels_in_use=$channels_in_use"
-      error $innerError
+    catch {
+      set ch [ns_conn channel]
+      if {[catch {thread::transfer $tid $ch} innerError]} {
+        set channels_in_use "??"
+        catch {set channels_in_use [bgdelivery do file channels]}
+        ns_log error "thread transfer failed, channel=$ch, channels_in_use=$channels_in_use"
+        error $innerError
+      }
+    } errorMsg
+    
+    ::thread::mutex unlock [my set mutex]
+    #ns_mutex unlock [my set bgmutex]
+    # my log "+++ unlock [my set bgmutex]"
+    
+    if {$errorMsg ne ""} {
+      error ERROR=$errorMsg
     }
-  } errorMsg
-  
-  ::thread::mutex unlock [my set mutex]
-  #ns_mutex unlock [my set bgmutex]
-  # my log "+++ unlock [my set bgmutex]"
-  
-  if {$errorMsg ne ""} {
-    error ERROR=$errorMsg
+    
+    if {$use_h264} {
+      #my log "MP4 q=[::xo::cc actual_query], h=[ns_set array [ns_conn outputheaders]]"
+      my do -async ::h264Spooler spool -delete $delete -channel $ch -filename $filename \
+          -context [list [::xo::cc requestor],[::xo::cc url],$query [ns_conn start]] \
+          -query $query \
+          -client_data $client_data
+    } else {
+      #my log "FILE SPOOL $filename"
+      my do -async ::fileSpooler spool -ranges $ranges -delete $delete -channel $ch -filename $filename \
+          -context [list [::xo::cc requestor],[::xo::cc url],$query [ns_conn start]] \
+          -client_data $client_data
+    }
+    #
+    # set the length for the access log (which is written when the
+    # connection thread is done)
+    ns_conn contentsentlength $size       ;# maybe overly optimistic
   }
-  
-  if {$use_h264} {
-    #my log "MP4 q=[::xo::cc actual_query], h=[ns_set array [ns_conn outputheaders]]"
-    my do -async ::h264Spooler spool -delete $delete -channel $ch -filename $filename \
-        -context [list [::xo::cc requestor],[::xo::cc url] [ns_conn start]] \
-        -query $query \
-        -client_data $client_data
-  } else {
-    #my log "FILE SPOOL $filename"
-    my do -async ::fileSpooler spool -ranges $ranges -delete $delete -channel $ch -filename $filename \
-        -context [list [::xo::cc requestor],[::xo::cc url] [ns_conn start]] \
-        -client_data $client_data
-  }
-  #
-  # set the length for the access log (which is written when the
-  # connection thread is done)
-  ns_conn contentsentlength $size       ;# maybe overly optimistic
-}
 
 ad_proc -public ad_returnfile_background {{-client_data ""} status_code mime_type filename} {
   Deliver the given file to the requestor in the background. This proc uses the
@@ -725,3 +736,10 @@
 bgdelivery proc spooler_release {spooler} {
   my do -async $spooler release
 }
+
+#
+# Local variables:
+#    mode: tcl
+#    tcl-indent-level: 2
+#    indent-tabs-mode: nil
+# End: