# Copyright for URLibService (c) 1995 - 2015, # by Gerald Banon. All rights reserved. # Version 2.1 # mirrorfind-.tcl # the field names are: # query (ex: query=ti+Zip) # file (ex: file=zip/README) # repository {ex: repository=dpi.inpe.br/banon/1999/07.30.23.45) # scenario (ex: scenario=1 - could be 1 or 2 - default is 1) # example: http://banon-pc.dpi.inpe.br:1905/find-/dpi.inpe.br/banon/1999/06.19.17.00?query=ti+Zip # opens the target file (if the repository exists) # example: http://banon-pc.dpi.inpe.br:1905/find-/dpi.inpe.br/banon/1999/06.19.17.00?query=ti+Zip&file=zip/README # opens the named file (if the repository exists) # # example: http://banon-pc.dpi.inpe.br:1907/find-/dpi.inpe.br/banon/2000/02.15.11.38.51?query=tit+Framing # opens the target file (if the repository exists) # example: http://banon-pc.dpi.inpe.br:1907/find-/dpi.inpe.br/banon/2000/02.15.11.38.51?query=tit+Framing&file=ch12.htm # opens the named file (if the repository exists) # example: http://banon-pc.dpi.inpe.br:1907/find-/dpi.inpe.br/banon/2000/02.15.11.38.51?query=tit+Framing&file=ch12.htm&repository=dpi.inpe.br/banon/1999/07.30.23.45 # example: http://banon-pc.dpi.inpe.br:1907/find-/dpi.inpe.br/banon/2000/02.15.11.38.51?query=tit+Framing&file=ch2.htm&repository=dpi.inpe.br/banon/1999/07.30.23.45 # opens the named file if it exists otherwise opens the target file # of the named repository. package provide dpi.inpe.br/banon/1998/08.02.08.56 2.1 # ---------------------------------------------------------------------- # Load # Load from the disk the value of a tcl variable # if the file doesn't exist the tcl variable is load with an # empty list proc Load {filePath varName {translation {auto}}} { # runs with start and post upvar $varName var if ![file exists $filePath] { set var {} return } if 0 { # for testing global homePath if [info exists homePath] { if [string equal {@siteList.txt} [file tail $filePath]] { set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] Load:\n[CallTrace]\n\n" Store log $homePath/@errorLog auto 0 a } } } if [catch {open $filePath r} fileId] { # puts stderr $fileId set var {} } else { fconfigure $fileId -translation $translation set var [string trim [read $fileId] \n] close $fileId } } # Load - end # ---------------------------------------------------------------------- # LoadWithBackup # example: LoadWithBackup $col/$loBiMiRep/doc/@siteList.txt fileContent # loads the most recent of: # $col/$loBiMiRep/doc/@siteList.txt and # $col/$loBiMiRep/doc/@siteList2.txt proc LoadWithBackup {filePath varName {translation {auto}}} { upvar $varName var set backupPath [file rootname $filePath]Backup[file extension $filePath] if [file exists $filePath] { set mtime [file mtime $filePath] } else { set mtime 0 } if [file exists $backupPath] { set backupMtime [file mtime $backupPath] } else { set backupMtime 0 } if {[string compare $mtime $backupMtime] == -1} { # mtime < backupMtime Load $backupPath var $translation } else { # mtime >= backupMtime Load $filePath var $translation } } # LoadWithBackup - end # ---------------------------------------------------------------------- # StartCommunication # async value is 0 or 1 # 1 means -async # encodingName value is for example iso8859-1 # value iso8859-1 is used only by FindMetadataRepositories and CreateOutput to send queries # token used in RemoteExecute proc StartCommunication {host port {async 1} {encodingName {}} {token {}}} { # proc StartCommunication {host port {async 1} {encodingName {}} {translation auto}} # global eval ;# used in Submit and MultipleSubmit global env global errorInfo # set xxx [info exists eval] # Store xxx C:/tmp/bbb.txt binary 0 a regsub {(\d{4}).(.)} $port {\1\2} port ;# 190510 -> 19050 regsub {^4430$} $port {800} port ;# 4430 -> 800 # see also GetConversionTable (utilities1.tcl) if $async { # set s [socket -async $host $port] # puts [list $host $port] # puts "" ;# to have the previous puts displayed if [catch {socket -async $host $port} s] { # couldn't open socket: invalid argument return -code error -errorinfo "StartCommunication: communication doesn't start: $s" } } else { # set s [socket $host $port] # puts [info exists eval] if [catch {socket $host $port} s] { # couldn't open socket: invalid argument # couldn't open socket: connection refused # couldn't open socket: address already in use # return -code error -errorinfo "StartCommunication: communication doesn't start: $s" # puts {try again} # set x 0; after 300 {set x 1}; vwait x ;# nice procedure # if [catch {socket $host $port} s] { return -code error -errorinfo "StartCommunication: communication with server \[$host $port\] doesn't start:\n--$errorInfo--\n" # } } } # puts $s # set eval(server,$s) $host:$port set eval(server,$s) [list $host $port] set eval(token,$s) $token if [string equal {} $encodingName] { if [info exists env(ENCODING_SYSTEM)] { # the calling procedure is a cgi script fconfigure $s -buffering line -encoding $env(ENCODING_SYSTEM) ;# solves the accent problem - equivalent of applying encoding convertfrom to the reply } else { # the calling procedure is not a cgi script fconfigure $s -buffering line -encoding [encoding system] ;# solves the accent problem - equivalent of applying encoding convertfrom to the reply } } else { # used only by FindMetadataRepositories and CreateOutput fconfigure $s -buffering line -encoding $encodingName ;# solves the accent problem - used to send queries coded iso8859-1 - otherwise a search from a utf-8 server may not find words with accent in an iso8859-1 server (ex: Lattes importation done in plutao) } # fconfigure $s -translation $translation return $s } # StartCommunication - end # ---------------------------------------------------------------------- # Incr # example: # Incr queueLengthArray(banon-pc3 800) # used in mirrorfind-.tcl only # not used # when Incr is called in PutQuery vwait in MultipleSubmit waits for ever # the same problem occurs when calling ComputeVersionState in CreateBriefEntry- GJFB in 2013-04-09 proc Incr {args} { global serverAddressWithIP global currentPostPid return [Execute $serverAddressWithIP "incr $currentPostPid $args" 0] ;# not async } # Incr - end # ---------------------------------------------------------------------- # PutQuery proc PutQuery {pID sock query} { global ${pID}controlTable ;# set to 0 in this procedure global ${pID}runningTable ;# set in this procedure global ${pID}notWritableTable ;# set in this procedure global tcl_platform # global ${pID}lastPartialReplyTimeTable ;# set in this procedure ;# commented by GJFB in 2013-03-10 - otherwise not writable sites (sites that don't reply) are seen as running (== 1) and it is necessary to wait at least timeInterval2 (which may be too long for exemple with GetMetadataRepositories) global ${pID}lastPartialReplyTimeTable ;# set in this procedure ;# added by GJFB in 2013-03-12 because of a disfunction in Local collections not fully accessible (in About this Archive) global homePath global URLibServiceRepository global eval # global maximumQueueLength ;# set in MultipleSubmit # Store sock C:/tmp/bbb.txt auto 0 a if ![info exists ${pID}controlTable($sock)] {return} ;# added by GJFB in 2014-08-31 - after ${pID}controlTable is unset at the end of MultipleSubmit (CleanUpTable) PutQuery may still be called before leaving the current cgi script if [set ${pID}controlTable($sock)] { # puts [list $sock query = $query
] # communication started (put only once) # socket may not be connected ... # catch {puts $sock $query} ;# unix returns an writing error when the remote server is down - doesn't work: stall # set xxx [list client side $sock query = $query] ;# <<< to trace channel communication # Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication # set xxx [CallTrace] # Store xxx C:/tmp/bbb auto 0 a # set ${pID}lastPartialReplyTimeTable($sock) [clock seconds] # set ${pID}lastPartialReplyTimeTable($sock) [clock clicks -milliseconds] ;# commented by GJFB in 2013-03-10 - otherwise not writable sites (sites that don't reply) are seen as running (== 1) and it is necessary to wait at least timeInterval2 (which may be too long for exemple with GetMetadataRepositories) set ${pID}lastPartialReplyTimeTable($sock) [clock clicks -milliseconds] ;# added by GJFB in 2013-03-12 because of a disfunction in Local collections not fully accessible (in About this Archive) if 1 { ## commented by GJFB in 2015-05-31 # useless # seems doesn't work - for example, when calling GetMetadataRepositories as stated in DisplayNumber (when executing DisplayNumberOfEntries while updating "Tabela fornecendo os dados para o c�lculo dos indicadores F�sicos e Operacionais IPUB e IGPUB: ano de 2015") one gets the following error: # CreateOutput: unexpected searchResult value: archiveaddress marte.sid.inpe.br contenttype Data ibi {rep dpi.inpe.br/marte/2011/07.05.19.58 ibip 3ERPFQRTRW/3A2QPQ8} ibi.archiveservice {rep dpi.inpe.br/banon/2003/12.10.19.30} ibi.platformsoftware {rep dpi.inpe.br/banon/1998/08.02.08.56} state Original timestamp 2011-07-05T19:58:30Z url http://marte.sid.inpe.br/col/dpi.inpe.br/marte/2011/07.05.19.58/doc/p0937.pdf urlkey 1432947277-45313357338820304 # indicating that the current socket has been prematurely closed when calling GetURLPropertyList # Clear channel fconfigure $sock -blocking 0 catch {gets $sock garbage} ;# gets may issue an error, e.g.: error reading "sock9": connection refused fconfigure $sock -blocking 1 # Clear channel - end } if {$tcl_platform(platform) == "windows"} { if [catch {puts $sock $query}] {return} ;# needed with tcl 8.3.1 # flush $sock # set xxx [CallTrace] # Store xxx C:/tmp/bbb.txt auto 0 a } else { puts $sock $query ;# may result in: error writing "sock5": broken pipe } set ${pID}controlTable($sock) 0 ;# put only once set ${pID}runningTable($sock) 1 ;# could be any value if [info exists eval(server,$sock)] { set ${pID}notWritableTable($eval(server,$sock)) 1 ;# could be any value } } } # PutQuery - end # ---------------------------------------------------------------------- # GetReply # not used proc GetReply2 {pID sock replyListName {callBack {}}} { upvar #0 $replyListName replyList global ${pID}numberOfSatisfiedQueries ;# set in MultipleSubmit and updated in this procedure global ${pID}foundIndicator ;# used with scenario 1 global ${pID}controlTable ;# unset in this procedure global ${pID}runningTable ;# set in PutQuery and unset in this procedure global ${pID}notWritableTable ;# partially unset in this procedure global ${pID}lastPartialReplyTimeTable ;# changed in this procedure global eval # global listOfActiveSites ;# used in CreateOutput and CreateMirror global ${pID}listOfActiveSites ;# used in CreateOutput and CreateMirror global ${pID}localURLibClientSocketIdList ;# set in MultipleSubmit and updated in this procedure - added by GJFB in 2012-12-16 global homePath global URLibServiceRepository # Store sock C:/tmp/bbb.txt auto 0 a upvar #0 $replyListName replyList upvar #0 $eval(token,$sock)(status) status # if [info exists ${pID}notWritableTable] {unset ${pID}notWritableTable} if [info exists ${pID}notWritableTable($eval(server,$sock))] {unset ${pID}notWritableTable($eval(server,$sock))} # gets $sock reply if [catch {gets $sock reply}] { # unix returns a reading error when the remote server is down close $sock set status error return } # puts [list $sock reply = --$reply--
] # set xxx [list client side $sock reply = --$reply--] ;# <<< to trace channel communication # Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication # close $sock if [string equal $reply {}] { # CLOSE close $sock if [info exists replyList] { set status ok if ![string equal {} $callBack] {$callBack $eval(token,$sock)} } else { set status eof } # puts $sock # puts closed if [info exists ${pID}numberOfSatisfiedQueries] { # if added by GJFB in 2013-02-05 # when MultipleSubmit returns, all channels are not necessary closed but ${pID}numberOfSatisfiedQueries # might be unset by MultipleExecute to free memory and consequently could not exist when a channel # is closed if [info exists eval(server,$sock)] { # if added by GJFB in 2013-04-26 - after eval is unset at the end of MultipleSubmit GetReply may still be called before leaving the current cgi script incr ${pID}numberOfSatisfiedQueries lappend ${pID}listOfActiveSites $eval(server,$sock) } } unset ${pID}controlTable($sock) if [info exists ${pID}runningTable($sock)] {unset ${pID}runningTable($sock)} ;# if added by GJFB in 2013-01-10 # unset ${pID}lastPartialReplyTimeTable($sock) if [info exists ${pID}lastPartialReplyTimeTable($sock)] {unset ${pID}lastPartialReplyTimeTable($sock)} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable($sock) is not set anymore in PutQuery set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] ;# added by GJFB in 2012-12-16 and commented in 2012-12-29 set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] ;# added by GJFB in 2012-12-16 to avoid trying closing the socket again in MultipleSubmit (see "Close the sockets still open") if [string equal {} [set ${pID}localURLibClientSocketIdList]] { unset ${pID}localURLibClientSocketIdList unset ${pID}controlTable unset ${pID}runningTable # unset ${pID}lastPartialReplyTimeTable if [info exists ${pID}lastPartialReplyTimeTable($sock)] {unset ${pID}lastPartialReplyTimeTable($sock)} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable($sock) is not set anymore in PutQuery } # unset eval(server,$sock) # if [info exists eval(server,$sock)] {unset eval(server,$sock)} ;# added by GJFB in 2012-04-30 return } if {[string equal $reply {}] || [string equal $reply {}]} { # it is better to test an empty reply right here because an abnormal communication might occur with the channel staying permanently readable and returning an empty reply (occured communicating with mtc-m12) close $sock set status eof unset ${pID}controlTable($sock) if [info exists ${pID}runningTable($sock)] {unset ${pID}runningTable($sock)} ;# if added by GJFB in 2013-01-10 # unset ${pID}lastPartialReplyTimeTable($sock) if [info exists ${pID}lastPartialReplyTimeTable($sock)] {unset ${pID}lastPartialReplyTimeTable($sock)} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable($sock) is not set anymore in PutQuery set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] ;# added by GJFB in 2012-12-16 and commented in 2012-12-29 set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] ;# added by GJFB in 2012-12-16 to avoid trying closing the socket again in MultipleSubmit (see "Close the sockets still open") if [string equal {} [set ${pID}localURLibClientSocketIdList]] { unset ${pID}localURLibClientSocketIdList unset ${pID}controlTable unset ${pID}runningTable # unset ${pID}lastPartialReplyTimeTable if [info exists ${pID}lastPartialReplyTimeTable] {unset ${pID}lastPartialReplyTimeTable} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable is not set anymore in PutQuery } # unset eval(server,$sock) return } # if {$reply != ""} # could be used again after all migration being done (2007-10-08) # puts --$reply-- # if {$reply != "" && $reply != ""} # set ${pID}foundIndicator 1 ;# used with scenario 1 # LAPPEND lappend replyList $reply ;# now within the if (done in 2007-09-29) - RBMET_SAULO[1].pdf -> {RBMET_SAULO[1].pdf} # set ${pID}lastPartialReplyTimeTable($sock) [clock clicks -milliseconds] ;# must be within the if because under abnormal communication, the channel stays permanently readable returning an empty reply (occured communicating with mtc-m12) # # # set ${pID}lastPartialReplyTimeTable($sock) [clock seconds] set ${pID}lastPartialReplyTimeTable($sock) [clock clicks -milliseconds] } # scenario argument added by GJFB in 2015-01-01 to solve a scenario 1 problem: no callback done with scenario 1 # ibiResolutionFlag is set in FindURLPropertyList only # 1 means to force empty reply to assume value {{}} - needed when executing an IBI resolution proc GetReply {pID sock replyListName scenario {callBack {}} {ibiResolutionFlag 0}} { global ${pID}numberOfSatisfiedQueries ;# set in MultipleSubmit and updated in this procedure global ${pID}foundIndicator ;# used with scenario 1 global ${pID}controlTable ;# partially unset in this procedure global ${pID}runningTable ;# set in PutQuery and partially unset in this procedure global ${pID}notWritableTable ;# partially unset in this procedure global ${pID}lastPartialReplyTimeTable ;# changed in this procedure global eval global ${pID}listOfActiveSites ;# used in CreateOutput and CreateMirror global ${pID}localURLibClientSocketIdList ;# set in RemoteExecute and updated in this procedure - added by GJFB in 2014-09-06 # global homePath # global URLibServiceRepository # puts [info exists eval(token,$sock)] # Store sock C:/tmp/bbb.txt auto 0 a # set xxx [info exists eval(token,$sock)] # Store xxx C:/tmp/bbb.txt auto 0 a # set xxx OK # Store xxx C:/tmp/bbb.txt auto 0 a if 1 { ## commented by GJFB in 2015-05-31 to try to avoid going on using the same socket to get the result of another command (see comment at Clear channel) if ![info exists eval(token,$sock)] {close $sock; return} ;# added by GJFB in 2014-08-31 - after eval is unset at the end of MultipleSubmit (CleanUpTable) GetReply may still be called before leaving the current cgi script } upvar #0 $replyListName replyList upvar #0 $eval(token,$sock)(status) status if ![info exists eval(server,$sock)] { ;# added by GJFB in 2014-08-31 - after eval is unset at the end of MultipleSubmit (CleanUpTable) GetReply may still be called before leaving the current cgi script if 1 { ## commented by GJFB in 2015-05-31 to try to avoid going on using the same socket to get the result of another command (see comment at Clear channel) close $sock } set status eof return } if [info exists ${pID}notWritableTable($eval(server,$sock))] {unset ${pID}notWritableTable($eval(server,$sock))} # gets $sock reply if [catch {gets $sock reply}] { # unix returns a reading error when the remote server is down close $sock set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] set status error return } # puts [list $sock reply = --$reply--
] # set xxx [list client side $sock reply = --$reply--] ;# <<< to trace channel communication # Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication if $scenario { # scenario 1 # if added by GJFB in 2015-01-01 if [string equal {} $reply] { # with scenario 1 receiving an means no reply (see ServeLocalCollection) - this should be converted into an empty reply if ![info exists replyList] {set replyList {}} } else { # nonempty reply lappend replyList $reply set ${pID}foundIndicator 1 ;# used with scenario 1 } if ![string equal {} $callBack] {$callBack $eval(token,$sock)} close $sock set status ok return } # scenario 0 if [string equal $reply {}] { # CLOSE close $sock set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] # set xxx "replyList exists == [info exists replyList]" # Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication if [info exists replyList] { set status ok if 1 { if ![string equal {} $callBack] {$callBack $eval(token,$sock)} } else { if ![string equal {} $callBack] { catch {$callBack $eval(token,$sock)} xxx Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication } } } else { # empty reply set status eof if $ibiResolutionFlag { ;# if added by GJFB in 2015-03-23 - ibiResolutionFlag is set in FindURLPropertyList - useful when executing an IBI resolution # http://urlib.net/LK47B6W/362SFKH?ibiurl.requireddocumentstate=Secure+Original - all the sites must be scanned but the ones that don't have the ibi must return {{}} # http://urlib.net/LK47B6W/E6H5HH?ibiurl.requireddocumentstate=Original - the original cannot be reached (i.e., all the sites must be tested but http://gprb0705.sid.inpe.br is searched protected (see the @sitesHavingReadPermission.txt file content in $loCoInRep/doc) and must return {{}} set replyList {{}} ;# otherwise ${token}(data) in CreateListOfibiProperties2 called below, doesn't exist $callBack $eval(token,$sock) ;# even empty reply must be processed to avoid waiting for the time-out of the while in FindURLPropertyList } } # puts $sock # puts $status # puts closed if [info exists ${pID}numberOfSatisfiedQueries] { # if added by GJFB in 2013-02-05 # when MultipleSubmit returns, all channels are not necessary closed but ${pID}numberOfSatisfiedQueries # might be unset by MultipleExecute to free memory and consequently could not exist when a channel # is closed if [info exists eval(server,$sock)] { # if added by GJFB in 2013-04-26 - after eval is unset at the end of MultipleSubmit GetReply may still be called before leaving the current cgi script incr ${pID}numberOfSatisfiedQueries lappend ${pID}listOfActiveSites $eval(server,$sock) } } # unset ${pID}controlTable($sock) if [info exists ${pID}runningTable($sock)] {unset ${pID}runningTable($sock)} ;# if added by GJFB in 2013-01-10 if [info exists ${pID}lastPartialReplyTimeTable($sock)] {unset ${pID}lastPartialReplyTimeTable($sock)} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable($sock) is not set anymore in PutQuery return } if {[string equal $reply {}] || [string equal $reply {}]} { # it is better to test an empty reply right here because an abnormal communication might occur with the channel staying permanently readable and returning an empty reply (occured communicating with mtc-m12) close $sock set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] set status eof # unset ${pID}controlTable($sock) if [info exists ${pID}runningTable($sock)] {unset ${pID}runningTable($sock)} ;# if added by GJFB in 2013-01-10 if [info exists ${pID}lastPartialReplyTimeTable($sock)] {unset ${pID}lastPartialReplyTimeTable($sock)} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable($sock) is not set anymore in PutQuery return } # set ${pID}foundIndicator 1 ;# used with scenario 1 # LAPPEND # puts $replyListName # norm simplification (part of the implementation not needed - would work only using the option new code (newCodde == 1)) if 1 { lappend replyList $reply ;# now within the if (done in 2007-09-29) - RBMET_SAULO[1].pdf -> {RBMET_SAULO[1].pdf} } else { set replyList $reply } # set xxx [list client side $sock replyList = --$replyList--] ;# <<< to trace channel communication # Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication # set ${pID}lastPartialReplyTimeTable($sock) [clock seconds] set ${pID}lastPartialReplyTimeTable($sock) [clock clicks -milliseconds] # set status ok ;# needed for short reply - for example, when calling UpdateSiteList that returns a flag value } # GetReply - end # ---------------------------------------------------------------------- # ConcatReplies # used in MultipleSubmit (new code) only proc ConcatReplies {token} { global $token upvar #0 replyListName replyListName upvar #0 $replyListName replyList set reply [set ${token}(data)] # set xxx --$reply-- # Store xxx C:/tmp/bbb.txt auto 0 a # puts --$reply-- # norm simplification (part of the implementation not needed) if 1 { # CONCAT if [info exists replyList] { set replyList [concat $replyList $reply] } else { set replyList $reply } } else { # LAPPEND lappend replyList $reply } } # ConcatReplies - end # ---------------------------------------------------------------------- # ReturnCommunicationAddress # examples of serverAddress: # banon-pc2.dpi.inpe.br:1905 (old usage) # {banon-pc2.dpi.inpe.br 19050} # banon-pc2.dpi.inpe.br:80 (old usage) # {banon-pc2.dpi.inpe.br 800} # {150.163.2.174 800} # {marte2.sid.inpe.br 802} # marte2.sid.inpe.br:80 - ReturnCommunicationAddress doesn�t solve this case (virtual host) - GetServerAddressFromHTTPHost must be used instead # the result is always of the form {ipAddress urlibPort} proc ReturnCommunicationAddress {serverAddress} { if ![regexp {(.*) +(.*)} $serverAddress m serverName urlibPort] { # old usage # puts [CallTrace] # puts $serverAddress if [regexp {(.*):(.*)} $serverAddress m serverName serverPort] { set urlibPort ${serverPort}0 } else { set serverName $serverAddress set urlibPort 800 } } return [list $serverName $urlibPort] ;# {banon-pc2.dpi.inpe.br 800} } # ReturnCommunicationAddress - end # ---------------------------------------------------------------------- # ProcessWritableSocket # used in MultipleSubmit only proc ProcessWritableSocket {clicks afterID} { global x$clicks after cancel $afterID set x$clicks 0 } # ProcessWritableSocket - end # ---------------------------------------------------------------------- # MultipleSubmit # examples of replyName: wordOccurrenceList, numberOfItems, searchResult, ... # There are three scenarios # # 1. search scenario (scenario value is 0) # this scenario ends: # a. after a predefined delay if no sites are writable # or # b. when all sites that are returning have sent their reply # obs: a site is not returning when it doesn't return any # partial reply after $timeInterval2 milliseconds # In such case, the communication with the site is not closed (to allow channel flushing) # but warning message is written in $homePath/@errorLog # # 2. find scenario 1 (scenario value is 1) # this scenario ends at the first occurrence of two events: # a. a non-empty reply is returned # b. after a long predefined delay # OBS: works only with replies consisting of a list consisting of just one element # # 3. find scenario 2 (scenario value is 2) - NOT USED - obsolete # this scenario ends at the first occurrence of two events: # a. after short predefined delays if at least one site has sent # a non-empty reply # b. after a long predefined delay if no sites have sent a non-empty reply ## used in ComputeVersionState (in the old version) # used in: # CreateMirror (mirror.tcl) # Find- (mirrorfind-) # CreateOutput (utilities1.tcl) # Statistics (statistics.tcl) # GetWordOccurrenceList (utilities1.tcl) # FindBannerAddress (utilities1.tcl) # InformURLibSystem (utilitiesStart.tcl) # - (change.tcl) # FindSite (utilities1.tcl) # pID is {} or [pid] # The scope of MultipleSubmit is the local site plus the sites # defined in the @siteList.txt file located at col/$currentRep/doc # where currentRep is a mirror repository # if col/$currentRep/doc doesn't contain a @siteList.txt file, then # the scope reduces to the local site. # if currentRep doesn't exist then the @siteList.txt of the loBiMiRep is used # If the siteList argument is not {} the above scope is ignored and # the scope is defined by this argument value. # Each line of the @siteList.txt file defined a specific site and # consists of three mandatory arguments and three optional ones: # serverAddress localCollectionIndexRepository ipAddress [versionStamp administratorEMailAddress staticIPFlag] # Example: # sputnik.dpi.inpe.br:1910 dpi.inpe.br/banon/2000/03.31.17.47 150.163.2.4 {2000:03.31.17.54.42 dpi.inpe.br/banon/1999/01.09.22.14} banon@dpi.inpe.br 1 # siteList variable is used by FindBannerAddress and MultipleExecute # (see utilities1.tcl) # item examples of siteList: # banon-pc2.dpi.inpe.br:1905 (old usage) # {banon-pc2.dpi.inpe.br 19050} # banon-pc2.dpi.inpe.br:80 (old usage) # {banon-pc2.dpi.inpe.br 800} # {150.163.2.174 800} # {sbsr.sid.inpe.br 802} # example (see CreateOutput): # set searchResultList [MultipleExecute $siteList $query 0 2] # encodingName value is for example iso8859-1 # value iso8859-1 is used only by FindMetadataRepositories and CreateOutput to send queries # timeOut maximum waiting time in milliseconds proc MultipleSubmit { pID query replyName scenario {siteList {}} {level 1} {encodingName {}} {timeOut 999999} } { # set xxx [list $pID $query $replyName $scenario $siteList] # Store xxx C:/tmp/bbb.txt auto 0 a global ${pID}numberOfSatisfiedQueries ;# set in this procedure and updated in GetReply global ${pID}foundIndicator ;# set in this procedure and updated in GetReply global numberOfSites ;# used in CreateMirror (mirror.tcl) and DisplayNumberOfEntries global listOfSites ;# used in CreateOutput global ${pID}listOfActiveSites ;# used in CreateOutput and CreateMirror global ${pID}controlTable ;# set to 1 in this procedure global loCoInRepList ;# used in LoopOverEntries (utilities1.tcl) global ${pID}runningTable ;# set in PutQuery global ${pID}notWritableTable ;# used in this procedure global ${pID}lastPartialReplyTimeTable ;# used in this procedure global loCoInRep ;# used when not running a cgi-script global loBiMiRep ;# used when currentRep is not defined and siteList is empty global homePath ;# used when not runnning a cgi-script global serverAddress ;# used when not runnning a cgi-script global serverAddressWithIP ;# used when not runnning a cgi-script global eval ;# unset in this procedure global connected global clicks ;# set in the .cgi files global env global errorTrace ;# set to 0 in CreateTclPage to avoid any Store within the slave interp # global ${pID}localURLibClientSocketIdList ;# set in this procedure and updated in GetReply - added by GJFB in 2012-12-16 global ${pID}localURLibClientSocketIdList ;# set in this procedure and updated in RemoteExecute - added by GJFB in 2014-08-31 global URLibServiceRepository global maximumQueueLength ;# set in this procedure - added by GJFB in 2013-03-30 to solve the problem of readable but not writable sites global queueLengthFlag # set xxx OK # Store xxx C:/tmp/bbb.txt binary 0 a set maximumQueueLength 10 ;# beyond the maximumQueueLength the sites that don't reply (readable but not writable) are not considered running in the while below # see also "# reset" in PutQuery to tune MultipleSubmit up # errorTrace is set post if [info exists env(ERROR_TRACE)] { set errorTrace $env(ERROR_TRACE) } # set errorTrace 1 # currentTime if {[info tclversion] > 8.4} {set currentTime [clock milliseconds]} else {set currentTime [clock seconds]} if {![info exists errorTrace] || $errorTrace} { if ![info exists clicks] {set clicks [clock clicks]} # if {[info tclversion] > 8.4} {set currentTime [clock milliseconds]} else {set currentTime [clock seconds]} } set waitingFlag 0 ;# set to 0 by GJFB in 2012-12-29 - the code for waiting is perhaps not necessary to avoid cross communications if $waitingFlag {global writeUserCodedPassword} ;# set in CreateTclPage ## upvar $level environment env # upvar environment env # upvar $level cgi cgi upvar $level currentRep currentRep set replyName $pID$replyName upvar #0 $replyName reply ;# used with error trace global replyListName ;# used in ConcatReplies only set replyListName $replyName ;# used in ConcatReplies only set searchRepository dpi.inpe.br/banon/1999/04.21.17.06 ;# needed in a query # (current) site if {[info exists env(SERVER_NAME)] && [info exists env(URLIB_PORT)]} { # the calling procedure is a cgi script set localServerName $env(SERVER_NAME) set localIPAddress $env(IP_ADDR) set urlibPort $env(URLIB_PORT) set site [list $localIPAddress $urlibPort] set serverAddressWithIP $site ;# used in this procedure only } else { # the calling procedure is not a cgi script set serverAddress2 [ReturnCommunicationAddress $serverAddress] set localServerName [lindex $serverAddress2 0] set serverAddressWithIP2 [ReturnCommunicationAddress $serverAddressWithIP] set localIPAddress [lindex $serverAddressWithIP2 0] set site $serverAddressWithIP # puts [CallTrace] } # siteList if 0 { puts {Content-Type: text/html} puts {} } # puts [info exists env] # puts 2-$env(DOCUMENT_ROOT) # puts --$siteList-- # set xxx --$siteList-- # Store xxx C:/tmp/bbb.txt binary 0 a # loCoInRep if [info exists env(LOCOINREP)] {set loCoInRep $env(LOCOINREP)} if {$siteList == {}} { # needs env # if ![info exists homePath] {set homePath $env(DOCUMENT_ROOT)} ;# works but is not complete secure if [info exists env(DOCUMENT_ROOT)] {set homePath $env(DOCUMENT_ROOT)} # puts [CallTrace]

# set xxx [CallTrace] # Store xxx C:/tmp/bbb.txt binary 0 a # puts $level # puts -[info exists currentRep] # puts $currentRep if [info exists currentRep] { # currentRep is defined Load $homePath/col/$currentRep/doc/@siteList.txt fileContent } elseif {[info exists loBiMiRep]} { # currentRep is not defined # example SearchRepository {} {ti tt} (from telnet) # SearchRepository when calling MultipleExecute to execute GetMetadataRepositories # FindSiteContainingTheOriginal when calling MultipleExecute to execute ReturnSiteContainingTheOriginal Load $homePath/col/$loBiMiRep/doc/@siteList.txt fileContent } else { set fileContent {} ;# just the current site (see below) } foreach {siteList loCoInRepList} [FormatSiteList $fileContent $site $loCoInRep] {break} } else { set siteList2 {} foreach site $siteList { lappend siteList2 [ReturnCommunicationAddress $site] ;# server port } set siteList $siteList2 } set siteList [lsort -unique $siteList] # puts --$siteList-- if 0 { puts {Content-Type: text/html} puts {} puts [CallTrace] puts
puts --$siteList-- puts
exit } # puts ==$query== # puts [subst $query] # exit # errorTrace is set post # if {[info exists env(ERROR_TRACE)] && $env(ERROR_TRACE)} # # 1 if {![info exists errorTrace] || $errorTrace} { set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MultipleSubmit (1 - $clicks): starting communication with the servers:\n$siteList\nthe query is: $query\nscenario is: $scenario\n" Store log $homePath/@errorLog auto 0 a # Store log $homePath/@multipleExecuteLog$clicks auto 0 a } # set ${pID}numberOfSatisfiedQueries 0 set ${pID}foundIndicator 0 set numberOfSites [llength $siteList] # puts $query # puts $numberOfSites set listOfSites $siteList set ${pID}listOfActiveSites {} set query2 [eval $query] # timeInterval set timeInterval [ReturnTimeOutReference] # Store siteList C:/tmp/bbb.txt auto 0 a # below, simplified code by GJFB in 2012-12-23 if $waitingFlag {set queueVarList {}} set newCode 1 if !$newCode { # old code set ${pID}localURLibClientSocketIdList {} foreach site $siteList { # set serverPort [ReturnCommunicationAddress $site] # foreach {serverName urlibPort} $serverPort {break} foreach {serverName urlibPort} $site {break} if $waitingFlag { # Waiting for the completion of other communications # added by GJFB in 2012-12-23 to avoid cross communications # otherwise one cgi-script (e.g., cgi/get.tcl) use the same channel as another # running cgi-script (e.g., cgi/submit.tcl when updating a tcl page) # in this case the reply may go to the wrong socket # WaitQueue StartCommunication $serverName$urlibPort ;# doesn't work with safe slave interpreter set queueVar $serverName-$urlibPort if [info exists writeUserCodedPassword] { # tcl page (see CreateTclPage) - Load cannot be used within a safe slave interperter # set xxx --$writeUserCodedPassword-- # Store xxx C:/tmp/bbb.txt auto 0 a set administratorCodedPassword $writeUserCodedPassword ;# - writeUserCodedPassword must be the administrator coded password otherwise WaitQueue2 do nothing and a cross comunication may occcur } else { Load $homePath/col/$loCoInRep/auxdoc/xxx data binary set data [UnShift $data] set administratorCodedPassword [lindex $data end] } Execute $serverAddressWithIP [list WaitQueue2 MultipleSubmit $queueVar $administratorCodedPassword] 0 ;# not async # Waiting for the completion of other communications - end } # catch below is effective for unix only # if [catch {StartCommunication $serverName $urlibPort 1} localURLibClientSocketId] # # START COMMUNICATION # puts $serverName if [catch {StartCommunication $serverName $urlibPort 1 $encodingName} localURLibClientSocketId] { # disabled if $waitingFlag { Execute $serverAddressWithIP [list LeaveQueue MultipleSubmit $queueVar] 0 ;# not async } continue } if $waitingFlag {lappend queueVarList $queueVar} set ${pID}controlTable($localURLibClientSocketId) 1 ;# communication started lappend ${pID}localURLibClientSocketIdList $localURLibClientSocketId } # catch {socket 127.0.0.1 19060} # couldn't open socket: connection refused # catch {socket 150.163.2.34 800} # couldn't open socket: connection timed out -> must be async # puts [set ${pID}localURLibClientSocketIdList] # set xxx [set ${pID}localURLibClientSocketIdList] # Store xxx C:/tmp/bbb auto 0 a foreach sock [set ${pID}localURLibClientSocketIdList] { fileevent $sock writable [list PutQuery $pID $sock $query2] } foreach sock [set ${pID}localURLibClientSocketIdList] { fileevent $sock readable [list GetReply $pID $sock $replyName $scenario] } } else { # new code set fasterFirstFlag 1 ;# the replies are joined in the order faster/first # set fasterFirstFlag 0 ;# the replies are joined in the order defines by siteList (like in FindURLPropertyList) set ${pID}localURLibClientSocketIdList {} set ${pID}tokenList {} foreach site $siteList { if $fasterFirstFlag { # set xxx --[list RemoteExecute $site $query2 ConcatReplies $encodingName $pID]-- # Store xxx C:/tmp/bbb.txt auto 0 a if [catch {RemoteExecute $site $query2 $scenario ConcatReplies $encodingName $pID} token] {continue} } else { if [catch {RemoteExecute $site $query2 $scenario {} $encodingName $pID} token] {continue} } global $token lappend ${pID}tokenList $token } } set numberOfQueries [llength [set ${pID}localURLibClientSocketIdList]] # Store numberOfQueries C:/tmp/bbb.txt auto 0 a # puts $scenario switch -exact -- $scenario { 2 { # find scenario 2 - NOT USED set connected 0 after 200 {set connected 1} vwait connected set time 0 while {$time < 1400} { # set connected 0 if [info exists connected] {unset connected} after 200 {set connected 1} vwait connected if [set ${pID}foundIndicator] {break} incr time 200 } } 1 { # find scenario 1 # after 1400 "set ${pID}foundIndicator 1" ;# works after 1400 set ${pID}foundIndicator 1 vwait ${pID}foundIndicator } 0 { # search scenario set command [lindex $query 1] # puts $timeInterval # Store command C:/tmp/bbb.txt auto 0 a # timeIntervalArray # set timeIntervalArray(GetNumberOfItems) [expr 2 * $timeInterval] ;# set to 2 for updating "Sobre este Arquivo" m17 doesn't respond using 2 # set timeIntervalArray(GetNumberOfItems) [expr 3 * $timeInterval] ;# set to 3 for updating "Sobre este Arquivo" # set timeIntervalArray(GetNumberOfItems) [expr 6 * $timeInterval] ;# set to 6 for updating "Sobre este Arquivo" at INPE site (number of references) or with the search expression at INPE: repository */2005/* and hostcollection, * # Migration 2011-01-15 # becomes obsolete from 2011-01-15 # set timees obsontervalArray(GetNumberOfItems) [expr 12 * $timeInterval] ;# set to 8 for updating "Sobre este Arquivo" at INPE md-m09 site (number of references) # Migration 2011-01-15 set timeIntervalArray(GetNumberOfReferences) [expr 12 * $timeInterval] ;# set to 8 for updating "Sobre este Arquivo" at INPE md-m09 site (number of references) # set timeIntervalArray(GetSiteInformation) [expr 1 * $timeInterval] set timeIntervalArray(CaptureRepository) [expr 30 * $timeInterval] ;# set to 30 for USB drive set timeIntervalArray(CheckPassword) [expr 6 * $timeInterval] ;# set to 6 because CheckPassword might need to seek in other sites (calling again CheckPassword) set timeIntervalArray(GetURLPropertyList) [expr 6 * $timeInterval] ;# set to 6 because many Get and Get- are not satisfied resulting in identifier not found warnings set timeIntervalArray(ReturnURLPropertyList) [expr 3 * $timeInterval] ;# set to 3 to let remote ReturnURLPropertyList return non empty value when called in ReturnURLPropertyList2 called in ResolveIBI called in BuildReturnPathArray called in Get # set timeIntervalArray(ReturnSiteContainingTheOriginal) [expr 6 * $timeInterval] if [string equal {GetMetadataRepositories} $command] { # set timeIntervalArray(GetMetadataRepositories) [expr 3 * $timeInterval] ;# set to 3 for updating "Sobre este Espelho" at INPE site (latest acquisitons/updates) # set timeIntervalArray(GetMetadataRepositories) [expr 30 * $timeInterval] ;# set to 30 for updating "Rela��o de teses e disserta��es com pend�ncias" at INPE site - time comsuming search (long search expression) # puts [lindex $query 4] ;# returns entrySearch # set factor [expr int([string length [lindex $query 4]] / 30.)] set factor [expr int([string length [lindex $query 4]] / 10.)] ;# needed with the following search expression at bibdigital: secondaryt [MNPRT][ATRUPD][NCPDQIE] and not secondaryk *[0-9]* and not ref Journal and not ref Conference and not ref Material and not ref Source and not ref Section # puts $factor # set timeIntervalArray(GetMetadataRepositories) [expr [expr [expr $factor > 1]?$factor:1] * $timeInterval] ;# timeInterval is multiplied by a factor depending upon the query length (length 300 => factor 10) # set timeIntervalArray(GetMetadataRepositories) [expr [expr [expr $factor > 3]?$factor:3] * $timeInterval] ;# timeInterval is multiplied by a factor depending upon the query length (length 300 => factor 30) 3 needed when looking up "secondaryk */?*" at bibdigital # set timeIntervalArray(GetMetadataRepositories) [expr [expr [expr $factor > 6]?$factor:6] * $timeInterval] ;# timeInterval is multiplied by a factor depending upon the query length (length 300 => factor 30) 6 needed when looking up "secondaryk */?*" or "journal, J* and index 0" at bibdigital # set timeIntervalArray(GetMetadataRepositories) [expr [expr [expr $factor > 10]?$factor:10] * $timeInterval] ;# timeInterval is multiplied by a factor depending upon the query length (length 300 => factor 30) 8 needed when looking up "referencetype, Conference Proceedings and size, * and hostcollection, *" at marte.dpi.inpe.br set timeIntervalArray(GetMetadataRepositories) [expr [expr [expr $factor > 12]?$factor:12] * $timeInterval] ;# timeInterval is multiplied by a factor depending upon the query length (length 300 => factor 30) 8 needed when looking up "referencetype, Conference Proceedings and size, * and hostcollection, *" at marte.dpi.inpe.br - added by GJFB in 2013-11-20 } # set timeIntervalArray(UpdateRepMetadataRep2) [expr 3 * $timeInterval] # timeInterval2 # timeInterval2 is the maximum time (in milliseconds) that scenario 0 waits to receive a partial reply ConditionalSet timeInterval2 timeIntervalArray($command) $timeInterval set timeInterval2 [Min $timeInterval2 $timeOut] ;# added by GJFB in 2012-04-06 - timeOut is set only in CreateOptionListForCopyright (CreateOptionListForCopyright is called in displayControl.tcl when using Misc form) # puts $timeInterval2 set time 0 ;# ms set running 0 # puts [list $query
] set delay 200 ;# ms - one must have at least one site running before 200 ms, otherwise close all sockets - 100 ms is not enough when some sites are not responding # set delay 500 ;# ms - one must have at least one site running before 500 ms, otherwise close all sockets - 200 ms is not enough with marte from plutao (ref Journal and y 2012) ;# commented by GJFB in 2013-03-12 because of a disfunction in Local collections not fully accessible (in About this Archive) while {$time < $delay || $running} { # puts [list $time < $delay || $running]
# puts [list [set ${pID}numberOfSatisfiedQueries] == "$numberOfQueries"] if {[set ${pID}numberOfSatisfiedQueries] == "$numberOfQueries"} {break} # if {[set ${pID}numberOfSatisfiedQueries] >= "$numberOfQueries"} {break} ;# added by GJFB in 2012-04-30 to prevent unexpected increment of numberOfSatisfiedQueries # if [string equal {} [array names ${pID}controlTable]] {break} # set connected 0 if [info exists connected] {unset connected} after 20 {set connected 1} vwait connected ;# wait 20 ms ;# this vwait waits for ever if Incr is called within PutQuery set running 0 # puts [list $time
] # puts [list [array names ${pID}runningTable]
] foreach sock [array names ${pID}runningTable] { if 1 { if 0 { # the call is to the local computer set running 1 ;# may result to an infinite loop break } else { # the call is to a remote computer # puts [list $eval(server,$sock) [info exists ${pID}lastPartialReplyTimeTable($sock)] [expr abs([clock clicks -milliseconds] - [set ${pID}lastPartialReplyTimeTable($sock)])] > $timeInterval2] if ![info exists ${pID}lastPartialReplyTimeTable($sock)] { ## no replies received # neither readable nor writable, or readable 2 times or more but not writable # added by GJFB in 2013-03-10 - otherwise not writable sites (sites that don't reply) are seen as running (== 1) and it is necessary to wait at least timeInterval2 (which may be too long for exemple with GetMetadataRepositories) ## leave running to 0 # if {$queueLength < $maximumQueueLength} # set running 1 ;# added by GJFB in 2013-03-12 because of a disfunction in Local collections not fully accessible (in About this Archive) - >>> with this, all the sites must be running properly otherwise the while loop may run systematically for a long time (depending on timeInterval2) (recalling: an improper site may be readable and not writable) # # } elseif {[expr abs([clock clicks -milliseconds] - [set ${pID}lastPartialReplyTimeTable($sock)])] > $timeInterval2} { # old partial reply ## old partial reply - close # close $sock ;# commented by JGFB in 2012-12-29 - closing should occur in GetReply to allow channel flushing - otherwise cross communications may be observed # unset ${pID}runningTable($sock) if [info exists ${pID}runningTable($sock)] {unset ${pID}runningTable($sock)} ;# if added by GJFB in 2011-05-09 # set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] # set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] # incr numberOfQueries -1 ;# added by GJFB in 2012-04-30 # if [info exists eval(server,$sock)] {unset eval(server,$sock)} ;# added by GJFB in 2012-04-30 # 2 if {![info exists errorTrace] || $errorTrace} { set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MultipleSubmit (2): server at $eval(server,$sock) is not returning while using sock = $sock and sending the query:\n\"$query\"\n[CallTrace]\n\n" # [2012:11.21.10.05.53] MultipleSubmit (2): server at 150.163.34.245 800 is not returning while using sock = sock3 and sending the query: Store log $homePath/@errorLog auto 0 a } } else { # not an old partial reply set running 1 # break ;# commented by GJFB in 2012-04-30 to allow in the same while loop the ending of other old replies } } } else { # doesn't work properly - executing Identity doesn't return while the current request is not completed set command "list Identity 1" set testSite [MultipleExecute [list $eval(server,$sock)] $command 1] # set testSite [Execute $eval(server,$sock) $command] # puts [list > $testSite
] if [string equal {} $testSite] { # doesn't return - close close $sock # unset ${pID}runningTable($sock) if [info exists ${pID}runningTable($sock)] {unset ${pID}runningTable($sock)} ;# if added by GJFB in 2011-05-09 incr ${pID}numberOfSatisfiedQueries -1 # set i [lsearch -exact [set ${pID}localURLibClientSocketIdList] $sock] # set ${pID}localURLibClientSocketIdList [lreplace [set ${pID}localURLibClientSocketIdList] $i $i] # 3 if {![info exists errorTrace] || $errorTrace} { set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MultipleSubmit (3): server at $eval(server,$sock) is not returning while using sock = $sock and sending the query:\n\"$query\"\n[CallTrace]\n\n" Store log $homePath/@errorLog auto 0 a } } else { # OK returning set running 1 } } } incr time 20 ;# ms if ![expr $time%1000] { # if {[info exists env(ERROR_TRACE)] && $env(ERROR_TRACE)} # # 4 if {![info exists errorTrace] || $errorTrace} { set serverList {} foreach sock [set ${pID}localURLibClientSocketIdList] { lappend serverList $eval(server,$sock) } set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MultipleSubmit (4 - $clicks): communication with the following servers is not still completed:\n$serverList\n[list $time < $delay || $running]\n[list timeInterval2 = $timeInterval2]\n[list [set ${pID}numberOfSatisfiedQueries] == --$numberOfQueries--]\n" Store log $homePath/@errorLog auto 0 a # Store log $homePath/@multipleExecuteLog$clicks auto 0 a } # } } ;# end of while # puts OK # end of search scenario (scenario value is 0) } } ;# end of switch if $newCode { if !$fasterFirstFlag { set reply {} ;# global variable } # puts ${pID}tokenList # set xxx ${pID}tokenList-[set ${pID}tokenList] # Store xxx C:/tmp/bbb.txt auto 0 a foreach token [set ${pID}tokenList] { # set xxx $token-[info exists ${token}(status)] # Store xxx C:/tmp/bbb.txt auto 0 a # puts [info exists ${token}(status)] # puts --[set ${token}(status)]-- # puts ${token}(data) # puts --[set ${token}(data)]-- # puts $token if !$fasterFirstFlag { # CONCAT # if [info exists ${token}(data)] {set reply [concat $reply [set ${token}(data)]]} ;# valid line - equivalent to the next one if [string equal {ok} [set ${token}(status)]] {set reply [concat $reply [set ${token}(data)]]} } CleanUp $token } } # puts --$reply-- if 0 { # commented by JGFB in 2012-12-29 - closing should occur in GetReply to allow channel flushing - otherwise cross communications may be observed # Close the sockets still open puts "${pID}localURLibClientSocketIdList = --[set ${pID}localURLibClientSocketIdList]--" puts [CallTrace] foreach sock [set ${pID}localURLibClientSocketIdList] { if [catch {close $sock}] { global errorInfo # 5 # set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MultipleSubmit (5): cannot close $sock:\n$errorInfo\n" # Store log $homePath/@errorLog auto 0 a } } # Close the sockets still open - end } if [info exists queueLengthFlag] { set notCurrentlyWritableSiteNameList [array names ${pID}notWritableTable] # puts --$notCurrentlyWritableSiteNameList-- if [file isdirectory $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites] { set pwd [pwd] cd $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites set notPreviouslyWritableSiteNameList [glob -nocomplain *] cd $pwd } else { set notPreviouslyWritableSiteNameList {} } foreach siteName $notPreviouslyWritableSiteNameList { # not previously replying site if {[lsearch $notCurrentlyWritableSiteNameList $siteName] == -1} { # currently replying site # reset file delete $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites/$siteName } else { # not currently replying site Load $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites/$siteName queueLength incr queueLength Store queueLength $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites/$siteName } } foreach siteName $notCurrentlyWritableSiteNameList { # not currently replying site if {[lsearch $notPreviouslyWritableSiteNameList $siteName] == -1} { # previously replying site file mkdir $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites set queueLength 1 ;# the site is considered not writable until it turns writable Store queueLength $homePath/col/$URLibServiceRepository/auxdoc/listOfNotWritableSites/$siteName } } } # Free memory CleanUpTable $pID # Free memory - end if {[info exists errorTrace] && $errorTrace} { # 6 if {[info tclversion] > 8.4} {set currentTime2 [clock milliseconds]} else {set currentTime2 [clock seconds]} set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MultipleSubmit (6 - $clicks): returning the reply:\n$reply\nexecuting time interval = [expr $currentTime2 - $currentTime]]\n" Store log $homePath/@errorLog auto 0 a file delete $homePath/@multipleExecuteLog$clicks } if $waitingFlag { foreach queueVar $queueVarList { Execute $serverAddressWithIP [list LeaveQueue MultipleSubmit $queueVar] 0 ;# not async } } # puts OK2 # set xxx OK # Store xxx C:/tmp/bbb.txt auto 0 a } # MultipleSubmit # ---------------------------------------------------------------------- # DecodeURL proc DecodeURL {url} { regsub -all {\[} $url {\[} url ;# doc/RBMET_SAULO[1].pdf -> doc/RBMET_SAULO\[1].pdf - with the inclusion of this line a change was needed in doc/cgi/script.tcl of dpi.inpe.br/banon-pc@1905/2005/02.19.00.40 (see GJFB in 2011-12-12) regsub -all {\]} $url {\]} url ;# doc/RBMET_SAULO\[1].pdf -> doc/RBMET_SAULO\[1\].pdf - with the inclusion of this line a change was needed in doc/cgi/script.tcl of dpi.inpe.br/banon-pc@1905/2005/02.19.00.40 (see GJFB in 2011-12-12) regsub -all {\+} $url { } url # regsub -all {%([0-9a-hA-H][0-9a-hA-H])} $url {[format %c 0x\1]} url ;# %2B -> + regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $url {[format %c 0x\1]} url ;# %2B -> + - added by GJFB in 2015-01-09 set url [subst $url] ;# doc/RBMET_SAULO\[1\].pdf -> doc/RBMET_SAULO[1].pdf # regsub -all {\+} $url { } url return $url } # DecodeURL - end # ---------------------------------------------------------------------- # Compare0 # used to compare dates in Find- # used to compare dates in FindRepositoryForFind- (see utilitiesMirror.tcl) proc Compare0 {a b} { set a0 [lindex $a 0] set b0 [lindex $b 0] return [string compare $a0 $b0] } # Compare0 - end # ---------------------------------------------------------------------- # Find- # used with mosaic proc Find- {{pID {}} {envList {}}} { global env # global cgi # global currentRep # global searchResult # global processID # if [info exist processID] if {$pID != {}} { # not a script # set seconds [clock seconds] ## Compute new process ID # if {$seconds == [lindex $processID 0]} { # set i [lindex $processID 1] # incr i # set processID [list $seconds $i] # set pID $seconds$i # } else { # set processID [list $seconds 1] # set pID ${seconds}1 # } ## Compute new process ID - end array set environment $envList set flag 0 } else { # a script # set pID {} array set environment [array get env] set flag 1 } # GLOBAL global ${pID}Reply # > if [info exists environment(QUERY_STRING)] { foreach {name value} [split $environment(QUERY_STRING) &=] { set cgi([DecodeURL $name]) [DecodeURL $value] } } set col ../../../../.. # set URLibServiceRepository dpi.inpe.br/banon/1998/08.02.08.56 set pathInfo [file split $environment(PATH_INFO)] # currentRep regsub -all { } [lrange $pathInfo 1 4] {/} currentRep # source ../$col/$URLibServiceRepository/doc/utilities1.tcl # set default values if ![info exists cgi(file)] {set cgi(file) {}} if ![info exists cgi(scenario)] {set cgi(scenario) 1} # extremity values are 0 for left and 1 for right if ![info exists cgi(extremity)] {set cgi(extremity) 1} # set default values - end set query {list FindRepositoryForFind- $cgi(query) $cgi(file) $cgi(extremity)} set scenario $cgi(scenario) # MULTIPLE SUBMIT set ${pID}Reply {} MultipleSubmit $pID $query Reply $scenario # set searchResult [subst $${pID}Reply] set resultList [set ${pID}Reply] unset ${pID}Reply if {[llength $searchResult] == 0} { # no repository found if [info exists cgi(repository)] { # use the default repository to return something # set site $environment(HTTP_HOST) # set site $environment(SERVER_NAME):$environment(SERVER_PORT) set site [list $environment(SERVER_NAME) $environment(URLIB_PORT)] set finalPath rep-/$cgi(repository) } else { if {$cgi(file) == ""} { # file name not specified set output [list {Content-Type: text/html} {} \ {no repository found}] if $flag { foreach line $output { puts $line } } return $output } else { # file name specified set file $cgi(file) set output [list {Content-Type: text/html} {} \ "no repository found containing the file $file"] if $flag { foreach line $output { puts $line } } return $output } } } else { # one or more repositories found # compare dates set searchResult [lsort -command Compare0 $searchResult] # select the most recent data set rep [lindex [lindex $searchResult end] 1] set site [lindex [lindex $searchResult end] 2] if {$cgi(file) == ""} { # file name not specified set finalPath rep-/$rep } else { # file name specified set file $cgi(file) set finalPath col/$rep/doc/$file } } set link [ReturnHTTPHost $site]/$finalPath set output [list "Location: http://$link" {}] if $flag { foreach line $output { puts $line } } return $output # < } # Find- - end # ---------------------------------------------------------------------- # ReturnHTTPHost # returns the local site http address if serverAddress2 is empty # otherwise returns the http address of the server defined in serverAddress2 # examples: # serverAddress2 output # banon-pc2.dpi.inpe.br:1905 banon-pc2.dpi.inpe.br:1905 # {banon-pc2.dpi.inpe.br 19050} banon-pc2.dpi.inpe.br:1905 # banon-pc2.dpi.inpe.br:80 banon-pc2.dpi.inpe.br # {banon-pc2.dpi.inpe.br 800} banon-pc2.dpi.inpe.br # {150.163.2.174 800} 150.163.2.174 # {mtc-m17.sid.inpe.br 802} mtc-m17.sid.inpe.br <<< should be sibgrapi.sid.inpe.br # doesn't find virtual host name proc ReturnHTTPHost {{serverAddress2 {}}} { # runs with post and a cgi-script global env global serverAddress ;# banon-pc2.dpi.inpe.br 800 if [string equal {} $serverAddress2] { if {[info exists env(SERVER_NAME)] && [info exists env(URLIB_PORT)]} { set serverName $env(SERVER_NAME) set urlibPort $env(URLIB_PORT) } else { foreach {serverName urlibPort} [ReturnCommunicationAddress $serverAddress] {break} } } else { foreach {serverName urlibPort} [ReturnCommunicationAddress $serverAddress2] {break} } if {$urlibPort < 1905} { # http port is 80 return $serverName ;# banon-pc2.dpi.inpe.br } else { regsub {.$} $urlibPort {} serverPort ;# drop the last digit return $serverName:$serverPort } } # ReturnHTTPHost - end # ---------------------------------------------------------------------- # MultipleExecute # Example: # set command [list list FindSite $currentRep $plus] # set siteRep [MultipleExecute [list $urlibSite] $command] # scenario values are 0, 1 or 2, see the meaning of these values in MultipleSubmit # encodingName value is for example iso8859-1 # value iso8859-1 is used only by FindMetadataRepositories and CreateOutput to send queries # timeOut used only when MultipleExecute is called in FindMetadataRepositories # freeMemory value is 0 or 1, 1 means to free memory (default) - used by MultipleExecute2 only proc MultipleExecute { siteList command {scenario 0} {level 1} {encodingName {}} {timeOut 999999} {freeMemory 1} } { upvar pID pID ;# set in this procedure and used in MultipleExecute2 only set pID [CreateProcessID $command] # pID use is necessary when MultipleExecute is called from # a procedure called upon an event like UpdateSiteList global ${pID}numberOfSatisfiedQueries ;# set in MultipleSubmit global ${pID}listOfActiveSites ;# set in MultipleSubmit # replyName set replyName ${pID}Reply # GLOBAL global $replyName # MULTIPLE SUBMIT set $replyName {} MultipleSubmit $pID $command Reply $scenario $siteList $level $encodingName $timeOut set resultList [set $replyName] # puts --$resultList-- unset $replyName if $freeMemory {unset ${pID}numberOfSatisfiedQueries} ;# added by GJFB in 2012-12-19 to free memory if $freeMemory {unset ${pID}listOfActiveSites} ;# added by GJFB in 2012-12-19 to free memory return $resultList } # MultipleExecute - end # ---------------------------------------------------------------------- # MultipleExecute2 # used in CreateOutput and DisplayDuplicates only # in addition to resultList of MultipleExecute, MultipleExecute2 # returns numberOfSatisfiedQueries and listOfActiveSites proc MultipleExecute2 { siteList command {scenario 0} {level 1} {encodingName {}} {timeOut 999999} } { set resultList [MultipleExecute $siteList $command $scenario [expr $level + 1] $encodingName $timeOut 0] global ${pID}numberOfSatisfiedQueries ;# set in MultipleSubmit global ${pID}listOfActiveSites ;# set in MultipleSubmit set numberOfSatisfiedQueries [set ${pID}numberOfSatisfiedQueries] set listOfActiveSites [set ${pID}listOfActiveSites] unset ${pID}numberOfSatisfiedQueries ;# free memory unset ${pID}listOfActiveSites ;# free memory return [list $resultList $numberOfSatisfiedQueries $listOfActiveSites] } # MultipleExecute2 - end # ---------------------------------------------------------------------- # FormatSiteList # formats the content of the file @siteList.txt into the argument siteList of MultipleSubmit # used in MultipleSubmit, FindURLPropertyList and Get only # fileContent is typically the content of @siteList.txt # site is the server address (with IP or not) of the current site # loCoInRep is the local collection index repository of the current site (optional) # returns the lists siteList and loCoInRepList # if loCoInRep is omitted then loCoInRepList is returned empty # it is assumed that if administratorEMailAddress is not empty then staticIPFlag must not be empty (not unposted) neither 0 (not dynamic IP) for the site to be included in siteList # outputFormat value is {site} (default) or {site loCoInRep2 archiveProtocol} proc FormatSiteList {fileContent site {loCoInRep {}} {outputFormat {site}}} { set fileContent [string trim $fileContent] regsub -all "\n+" $fileContent "\n" fileContent set siteRepIpList [split $fileContent \n] set siteList {} set loCoInRepList {} lappend siteList [list $site $loCoInRep USP] ;# current site if {[string equal {site} $outputFormat] && ![string equal {} $loCoInRep]} {lappend loCoInRepList [list or repository, $loCoInRep]} ;# for Contributors foreach siteRepIp $siteRepIpList { # foreach {site loCoInRep2 ip versionStamp administratorEMailAddress staticIPFlag} $siteRepIp {break} foreach {site loCoInRep2 ip archiveProtocol versionStamp administratorEMailAddress staticIPFlag} $siteRepIp {break} # versionStamp not used if [string equal {0} $staticIPFlag] {continue} ;# dynamic IP - added by GJFB in 2010-08-14 if {![string equal {} $administratorEMailAddress] && [string equal {} $staticIPFlag]} {continue} ;# unposted collection - added by GJFB in 2010-09-20 foreach {serverName urlibPort} [ReturnCommunicationAddress $site] {break} ;# it is assumed that site of virtual host is not in the form like marte2.sid.inpe.br:80 (old usage) but it is of the form {marte2.sid.inpe.br 802} lappend siteList [list [list $ip $urlibPort] $loCoInRep2 $archiveProtocol] if {[string equal {site} $outputFormat] && ![string equal {} $loCoInRep]} {lappend loCoInRepList "or repository, $loCoInRep2"} ;# for Contributors } if [string equal {site} $outputFormat] { set siteList2 $siteList set siteList {} foreach item $siteList2 { lappend siteList [lindex $item 0] } } return [list $siteList $loCoInRepList] } # FormatSiteList - end # ---------------------------------------------------------------------- # RemoteExecute # used in MultipleSubmit (new code) and FindURLPropertyList only # ibiResolutionFlag is set in FindURLPropertyList only # 1 means to force empty reply to assume value {{}} - needed when executing an IBI resolution proc RemoteExecute {serverAddress command scenario {callBack {}} {encodingName {}} {pID {}} {ibiResolutionFlag 0}} { if 0 { set xxx [list $serverAddress $command $callBack $encodingName $pID] Store xxx C:/tmp/bbb.txt auto 0 a } global tokenCounter global ${pID}controlTable ;# set to 1 in this procedure global ${pID}numberOfSatisfiedQueries ;# set in this procedure and updated in GetReply global ${pID}localURLibClientSocketIdList ;# set and updated in this procedure global errorInfo if {[info tclversion] < 8.5} { if ![info exist tokenCounter] {set tokenCounter 0} ;# needed with 8.4 } incr tokenCounter if ![info exists ${pID}numberOfSatisfiedQueries] { set ${pID}numberOfSatisfiedQueries 0 ;# updated in GetReply } if ![info exists ${pID}localURLibClientSocketIdList] { set ${pID}localURLibClientSocketIdList {} ;# set in this procedure and updated in GetReply - added by GJFB in 2012-12-16 } foreach {serverName urlibPort} $serverAddress {break} # START COMMUNICATION # catch below is effective for unix only if [catch {StartCommunication $serverName $urlibPort 1 $encodingName $tokenCounter} sock] { error $errorInfo } set ${pID}controlTable($sock) 1 ;# communication started (used to put query only once) lappend ${pID}localURLibClientSocketIdList $sock global $tokenCounter set ${tokenCounter}(status) eof # set ${tokenCounter}(status) ok set ${tokenCounter}(pid) $pID set ${tokenCounter}(sock) $sock fileevent $sock writable [list PutQuery $pID $sock $command] fileevent $sock readable [list GetReply $pID $sock ${tokenCounter}(data) $scenario $callBack $ibiResolutionFlag] # Store tokenCounter C:/tmp/bbb.txt auto 0 a return $tokenCounter } # RemoteExecute - end # ---------------------------------------------------------------------- # CleanUp # free memory created by RemoteExecute # used in MultipleSubmit and FindURLPropertyList only proc CleanUp {token} { global $token unset $token } # CleanUp - end # ---------------------------------------------------------------------- # CleanUpTable # free memory # used in MultipleSubmit and FindURLPropertyList only # not used proc CleanUpTable2 {{pID {}}} { global ${pID}notWritableTable ## global ${pID}numberOfSatisfiedQueries global ${pID}foundIndicator global eval # free memory # unset ${pID}numberOfSatisfiedQueries ;# commented by GJFB - used in CreateOutput # unset ${pID}foundIndicator if [info exists ${pID}foundIndicator] {unset ${pID}foundIndicator} # unset eval ;# added by GJFB in 2013-04-17 (was before just after each close socket) - commented by GJFB in 2013-05-11 if [info exists eval] {unset eval} ;# added by GJFB in 2013-05-11 (if is needed in standalone mode when running InformURLibSystem) if [info exists ${pID}notWritableTable] {unset ${pID}notWritableTable} # if [info exists ${pID}controlTable] {unset ${pID}controlTable} # if [info exists ${pID}lastPartialReplyTimeTable] {unset ${pID}lastPartialReplyTimeTable} # unset ${pID}localURLibClientSocketIdList } proc CleanUpTable {{pID {}}} { global ${pID}controlTable global ${pID}runningTable global ${pID}notWritableTable global ${pID}lastPartialReplyTimeTable # global ${pID}numberOfSatisfiedQueries global ${pID}foundIndicator global eval global ${pID}localURLibClientSocketIdList if [info exists ${pID}controlTable] {unset ${pID}controlTable} if [info exists ${pID}runningTable] {unset ${pID}runningTable} if [info exists ${pID}notWritableTable] {unset ${pID}notWritableTable} if [info exists ${pID}lastPartialReplyTimeTable] {unset ${pID}lastPartialReplyTimeTable} ;# if added by GJFB in 2013-03-11 - needed because ${pID}lastPartialReplyTimeTable is not set anymore in PutQuery # unset ${pID}numberOfSatisfiedQueries ;# commented by GJFB - used in CreateOutput - unset in MultipleExecute or MultipleExecute2 if [info exists ${pID}foundIndicator] {unset ${pID}foundIndicator} if [info exists eval] {unset eval} ;# added by GJFB in 2013-05-11 (if is needed in standalone mode when running InformURLibSystem) if 1 { ## commented by GJFB in 2015-05-31 to try to avoid going on using the same socket to get the result of another command (see comment at Clear channel) foreach sock [set ${pID}localURLibClientSocketIdList] { catch {close $sock} } } unset ${pID}localURLibClientSocketIdList # if [info exists ${pID}localURLibClientSocketIdList] {unset ${pID}localURLibClientSocketIdList} } # CleanUpTable - end # ---------------------------------------------------------------------- # CreateProcessID proc CreateProcessID {command} { global processCounter if 0 { # commented by GJFB in 2012-12-20 to avoid the assumption below global multipleSubmitID if ![info exists multipleSubmitID] {set multipleSubmitID 0} if {$multipleSubmitID == 100000} {set multipleSubmitID 0} ;# assumption: no more than 100000 MultipleExecute are running at the same time incr multipleSubmitID set pID $multipleSubmitID } if 0 { # commented by GJFB in 2014-09-06 to avoid repetition like: # puts [clock clicks]-[clock clicks]-[clock clicks]-[clock clicks] # => 1202786831-1202786832-1202786833-1202786833 if {[info tclversion] > 8.4} { set pID [clock microseconds] } else { set pID [clock clicks] } } if {[info tclversion] < 8.5} { if ![info exist processCounter] {set processCounter 0} ;# needed with 8.4 } incr processCounter if 1 { ## added by GJFB in 2014-07-22 to try to avoid the use of the same global variable by two distinct MultipleExecute procedures producing the same microseconds or clicks ## for example, to avoid error like: ## CreateOutput: unexpected searchResult value: state Unchecked ibi.platformsoftware {rep dpi.inpe.br/banon/1998/08.02.08.56} url.data http://marte.sid.inpe.br/col/dpi.inpe.br/sbsr@80/2008/11.12.17.39.40/doc/metadata.cgi encodingsystem utf-8 ibi {rep dpi.inpe.br/sbsr@80/2008/11.12.17.39.40} language {} redirecttometadata no timestamp 2013:09.14.02.02.26 ibi.nextedition {} ibi.translationlist {} site marte.sid.inpe.br ibi.metadatalist {} ## the result of GetMetadataRepositories appears to be the result of GetURLPropertyList # useful for debugging set procedureName {} foreach part $command { if [string equal {list} $part] {continue} set procedureName $part break } return $processCounter$procedureName } # set pID $pID$procedureName } # CreateProcessID - end # ----------------------------------------------------------------------