# Copyright for URLibService (c) 1995 - 2024,
# by Gerald Banon. All rights reserved.
# Version 2.1
# mirrorfind-.tcl
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 the 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/@siteListBackup.txt
# used by UpdateSiteList only
proc LoadWithBackup {filePath varName {translation {auto}}} {
upvar $varName var
if 0 {
# commented by GJFB in 2020-06-17 - has never been useful
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
}
} else {
Load $filePath var $translation
if {![regexp {[[:print:]]} $var]} {
# var doesn't contain printed characters
set backupPath [file rootname $filePath]Backup[file extension $filePath]
Load $backupPath var $translation
set log "the file $filePath is corrupted,\nthe file $backupPath was loaded instead"
StoreLog {alert} {LoadWithBackup} $log ;# added by GJFB in 2018-05-15
}
}
}
# 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]
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
# couldn't open socket: can't assign requested address
# couldn't open socket: host is unreachable (Name or service not known)
# return -code error -errorinfo "StartCommunication: communication doesn't start: $s"
return -code error -errorinfo "StartCommunication: communication with server \[$host $port\] doesn't start:\n--$errorInfo--\n"
}
}
# 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
fconfigure $s -buffering line -encoding $env(ENCODING_SYSTEM) ;# solves the accent problem - equivalent of applying encoding convertfrom to the reply - solves the accent problem at mtc-m12 (with utf-8 encoding system) when $loBiMiRep/doc/@wordOcurrence file doesn't exist and when updating the word occurence list fom the navigator - this last comment was added by GJFB in 2016-08-06
} 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 - this line doesn't solve the accent problem at mtc-m12 (with utf-8 encoding system) when updating the word occurence list fom the URLibService interface; the problem was solved in urlibScript/getWordOccurrence.tcl by adding the argument value iso8859-1 to the Store procedure - this last comment was added by GJFB in 2016-08-06
}
} 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
]
# => sock000001935D2C62C0 query = {GetURLPropertyList {clientinformation.ipaddress 192.168.0.112 parsedibiurl.ibi urlib.net/www/2021/04.27.01.57 parsedibiurl.backgroundlanguage en parsedibiurl.metadatafieldnamelist {booktitle contenttype copyright doi fullname identifier issn language metadatalastupdate metadatarepository mirrorrepository nextedition nexthigherunit parameterlist previousedition readergroup readpermission referencetype repository rightsholder shorttitle size targetfile title username} parsedibiurl.requiredsite {gjfb 19050}}}
# 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
# puts [list client side $sock query = $query]
# 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 0 {
## commented by GJFB in 2015-05-31
# commented again by GJFB in 2016-12-30
# 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 $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 CreateResponseList only
# 1 means to force empty reply to assume value {{}} - needed when executing an IBI resolution
# replyListName is ${tokenCounter}(data), ex: 1(data) - see RemoteExecute
proc GetReply {pID sock tokenDataName 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 $tokenDataName
# => 1(data)
# 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 ![info exists eval(token,$sock)] {
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)
## commented again by GJFB in 2016-12-30 to try solving the cross communication problem
# added by GJFB in 2017-01-05 - commenting don't solve the cross communication problem
close $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
}
return
}
upvar #0 $tokenDataName tokenData ;# ex: 1(data)
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)
## commented again by GJFB in 2016-12-30 to try solving the cross communication problem
# added by GJFB in 2017-01-05 - commenting don't solve the cross communication problem
close $sock
}
set status eof
return
}
if [info exists ${pID}notWritableTable($eval(server,$sock))] {unset ${pID}notWritableTable($eval(server,$sock))}
# GET
# gets $sock reply
if [catch {gets $sock reply}] {
# unix returns a reading error when the remote server is down
# CLOSE
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 == 1} {
# 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 tokenData] {set tokenData {}}
} else {
# nonempty reply
# SET tokenData
lappend tokenData $reply ;# ex: lappend 1(data) $reply
set ${pID}foundIndicator 1 ;# used with scenario 1
}
if ![string equal {} $callBack] {$callBack $eval(token,$sock)} ;# ex: 1(data) -> 1IdentityReply
# CLOSE
close $sock
set status ok
return
}
# scenario 0 and 2
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 "tokenData exists == [info exists tokenData]"
# Store xxx C:/tmp/bbb.txt auto 0 a ;# <<< to trace channel communication
if [info exists tokenData] {
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 CreateResponseList - 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 tokenData {{}} ;# 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 CreateResponseList
}
}
# 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
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
}
# norm simplification (part of the implementation not needed - would work only using the option new code (newCodde == 1))
if 1 {
lappend tokenData $reply ;# reply ->> 1(data) - now within the if (done in 2007-09-29) - RBMET_SAULO[1].pdf -> {RBMET_SAULO[1].pdf}
} else {
set tokenData $reply
}
# set xxx [list client side $sock tokenData = --$tokenData--] ;# <<< 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
# callBack procedure - called in GetReply
proc ConcatReplies {token} {
global $token
# global replyListName ;# set in MultipleSubmit - commented by GJFB in 2017-01-05 to avoid cross communications when running a tcl page with many searches for example
# puts $replyListName
# => 1IdentityReply
# global replyTrace ;# added by GJFB in 2017-01-01 for testing - set in this procedure - just used to trace its value in CreateOutput
set replyListName [set ${token}(replyname)] ;# added by GJFB in 2017-01-05 to avoid cross communications when running a tcl page with many searches for example - set in RemoteExecute
upvar #0 $replyListName replyList
# puts OK
set reply [set ${token}(data)] ;# 1(data) -> reply
# set xxx --$reply--
# Store xxx C:/tmp/bbb.txt auto 0 a
# puts --$reply--
# norm simplification (part of the implementation not needed)
# puts [info exists replyList]
if 1 {
# CONCAT
if [info exists replyList] {
set replyList [concat $replyList $reply] ;# 1IdentityReply reply -> 1IdentityReply
} else {
set replyList $reply ;# reply -> 1IdentityReply
}
} else {
# LAPPEND
lappend replyList $reply
}
# lappend replyTrace [list $token $reply $replyListName] ;# added by GJFB in 2017-01-01 for testing
}
# 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 {serverName 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 ;# it is assumed that the server is not a virtual host
} 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 (i.e., the site is down)
# 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)
# this scenario ends:
# a. after a predefined delay if no sites are writable
# or
# b. when at least one site has sent a non-empty reply
# or
# c. when all sites that are returning have sent their reply
# used in CreateResponseList only
# 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)
# CreateBriefEntry
# 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.
# level is used to localized currentRep when siteList is empty
# 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)
# example of item 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}
# {mtc-m21b.sid.inpe.br 804}
# 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 ;# set in StartCommunication
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
# puts "pID = --$pID-- - query = $query - replyName = $replyName - scenario = $scenario"
# => pID = --1GetMostRecentMetadataRep-- - query = list GetMostRecentMetadataRep dpi.inpe.br/banon/2004/02.16.09.30.00 10 - replyName = Reply - scenario = 0
# puts "
"
# puts "siteList --$siteList-- - level = $level - encodingName = $encodingName - timeOut = $timeOut"
# => siteList ---- - level = 3 - encodingName = iso8859-1 - timeOut = 999999
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
set replyName $pID$replyName ;# ex: 1IdentityReply
upvar #0 $replyName reply ;# used with error trace
# global replyListName ;# used in ConcatReplies only - commented by GJFB in 2017-01-05 to avoid cross communications when running a tcl page with many searches for example
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) ;# commented by GJFB in 2015-12-25 - not used
set site [list $env(IP_ADDR) $env(URLIB_PORT)]
set serverAddressWithIP $site ;# used in this procedure only (just when waitingFlag is 1)
} else {
# the calling procedure is not a cgi script
# set serverAddress2 [ReturnCommunicationAddress $serverAddress] ;# commented by GJFB in 2015-12-25 - not used
# set localServerName [lindex $serverAddress2 0] ;# commented by GJFB in 2015-12-25 - not used
# set serverAddressWithIP2 [ReturnCommunicationAddress $serverAddressWithIP] ;# commented by GJFB in 2015-12-25 - not used
# set localIPAddress [lindex $serverAddressWithIP2 0] ;# commented by GJFB in 2015-12-25 - not used
if {$siteList == {}} {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
upvar $level currentRep currentRep
# 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-+-
# set xxx -+-$siteList-+-
# Store xxx C:/tmp/bbb.txt binary 0 a
if 0 {
puts {Content-Type: text/html}
puts {}
puts [CallTrace]
puts
puts --$siteList--
puts
exit
}
# puts ==$query==
# puts [subst $query]
# exit
# errorTrace is set in 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 {
# puts --[list RemoteExecute $site $query2 $scenario ConcatReplies $encodingName $pID 0 $replyListName]--
# => --RemoteExecute {gjfb 19050} {GetURLPropertyList {clientinformation.ipaddress 192.168.0.112 parsedibiurl.ibi urlib.net/www/2021/04.27.01.57 parsedibiurl.backgroundlanguage en parsedibiurl.metadatafieldnamelist {booktitle contenttype copyright doi fullname identifier issn language metadatalastupdate metadatarepository mirrorrepository nextedition nexthigherunit parameterlist previousedition readergroup readpermission referencetype repository rightsholder shorttitle size targetfile title username} parsedibiurl.requiredsite {gjfb 19050}}} 2 ConcatReplies {} {} 0 listOfibiProperties--
# set xxx --[list RemoteExecute $site $query2 $scenario ConcatReplies $encodingName $pID 0 $replyListName]--
# Store xxx C:/tmp/bbb.txt auto 0 a
if [catch {RemoteExecute $site $query2 $scenario ConcatReplies $encodingName $pID 0 $replyListName} token] {continue}
} else {
if [catch {RemoteExecute $site $query2 $scenario {} $encodingName $pID 0 $replyListName} token] {continue}
}
global $token
lappend ${pID}tokenList $token
}
}
# set time1 [clock milliseconds]
set numberOfQueries [llength [set ${pID}localURLibClientSocketIdList]]
# Store numberOfQueries C:/tmp/bbb.txt auto 0 a
# puts $scenario
# switch -exact -- $scenario # ;# commented by GJFB in 2019-03-31
switch -regexp -- $scenario { ;# added by GJFB in 2019-03-31 to include scenario 2
1 {
# find scenario 1
# after 1400 "set ${pID}foundIndicator 1" ;# works
after 1400 set ${pID}foundIndicator 1
vwait ${pID}foundIndicator
}
{[02]} {
# search scenario (0)
# find scenario (2)
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]
# set timeIntervalArray(UpdateSiteList) [expr 12 * $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(ReturnConfirmation) [expr 3 * $timeInterval] ;# set to 3 to let Script in urlib.net/www/2014/03.16.03.40 return non empty confirmation value when called in UpdateSiteList called in Script in urlib.net/www/2014/03.22.01.53 (J8LNKB5R7W/3FUQHC5) called in InformURLibSystem called in post
if 0 {
# commented by GJFB in 2025-04-21
set timeIntervalArray(UpdateSiteList) [expr 32 * $timeInterval] ;# set to 32 to let Script in urlib.net/www/2014/03.22.01.53 (J8LNKB5R7W/3FUQHC5) in Resolver return a non empty staticIPFlag value when called in InformURLibSystem called in post - added by GJFB in 2024-10-20 to avoid error (17a) in post
set timeIntervalArray(ReturnConfirmation) [expr 16 * $timeInterval] ;# set to 16 to let Script in urlib.net/www/2014/03.16.03.40 (J8LNKB5R7W/3FTRH3S) in Archive return a non empty confirmation value when called in UpdateSiteList called in Script in urlib.net/www/2014/03.22.01.53 (J8LNKB5R7W/3FUQHC5) in Resolver called in InformURLibSystem called in post - added by GJFB in 2024-10-20 to avoid error (17a) in post
} else {
# added by GJFB in 2025-04-21 - double the time intevals
set timeIntervalArray(UpdateSiteList) [expr 64 * $timeInterval] ;# set to 32 to let Script in urlib.net/www/2014/03.22.01.53 (J8LNKB5R7W/3FUQHC5) in Resolver return a non empty staticIPFlag value when called in InformURLibSystem called in post - added by GJFB in 2024-10-20 to avoid error (17a) in post
set timeIntervalArray(ReturnConfirmation) [expr 32 * $timeInterval] ;# set to 16 to let Script in urlib.net/www/2014/03.16.03.40 (J8LNKB5R7W/3FTRH3S) in Archive return a non empty confirmation value when called in UpdateSiteList called in Script in urlib.net/www/2014/03.22.01.53 (J8LNKB5R7W/3FUQHC5) in Resolver called in InformURLibSystem called in post - added by GJFB in 2024-10-20 to avoid error (17a) in post
}
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
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
}
#
}
if {$scenario == 2 && ![string equal {} $reply]} {break}
} ;# end of WHILE
# puts OK
# end of search scenario (scenario value is 0)
}
} ;# end of switch
# set time2 [clock milliseconds]
# puts [expr $time2 -$time1]
if $newCode {
if !$fasterFirstFlag {
set reply {} ;# global variable
}
# puts ${pID}tokenList
# puts ${pID}tokenList-[set ${pID}tokenList]
# => tokenList-1
# 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)]]} ;# used with error trace
}
CleanUp $token
}
}
# puts --$reply-- ;# error trace tracing
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} {
# 5
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 (5 - $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
}
}
# set time3 [clock milliseconds]
# puts [expr $time3 -$time2]
# puts OK2
# set xxx OK
# Store xxx C:/tmp/bbb.txt auto 0 a
}
# MultipleSubmit - end
# ----------------------------------------------------------------------
# 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-m16b.sid.inpe.br 802} mtc-m16b.sid.inpe.br
# {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
# puts --$serverAddress--
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}
}
# puts --$urlibPort--
if {$urlibPort < 19050} {
# 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}
} {
# global replyName ;# added by GJFB in 2017-01-01 for testing - set in this procedure - just used to trace its value in CreateOutput
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 $replyName
# puts --$resultList--
unset $replyName ;# commented by GJFB in 2017-01-01 for testing
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 (when outputFormat value is site)
# in this case, item examples of siteList are (if outputFormat is site):
# {banon-pc2.dpi.inpe.br 19050}
# {banon-pc2.dpi.inpe.br 800}
# {150.163.2.174 800}
# {mtc-m21b.sid.inpe.br 804}
# used in MultipleSubmit, FindURLPropertyList, GetOptimizedListOfSites and Get only
# fileContent is typically the content of @siteList.txt
# site is the server address (with IP or not) of the current site - used to add the current site to the site list
# loCoInRep is the local collection index repository of the current site (optional when outputFormat is site)
# 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}
# {site loCoInRep2 archiveProtocol} used in GetOptimizedListOfSites
proc FormatSiteList {fileContent site {loCoInRep {}} {outputFormat {site}}} {
set fileContent [string trim $fileContent]
regsub -all "\n+" $fileContent "\n" fileContent
set siteRepIpList [split $fileContent \n]
# puts [CallTrace]
# puts --$siteRepIpList--
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} ;# commented by GJFB in 2017-02-20
foreach {site loCoInRep2 ip archiveProtocol versionStamp administratorEMailAddress} $siteRepIp {break} ;# added by GJFB in 2017-02-20 - staticIPFlag is treated separately below
set lastItem [lindex $siteRepIp end]
if ![regexp {^(0|1)$} $lastItem staticIPFlag] {set staticIPFlag {}} ;# added by GJFB in 2017-02-20 - staticIPFlag, if it exists, is the last, its value is 0 or 1
# 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 CreateResponseList only
# replyListName is set in MultipleSubmit 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} {replyListName {}}
} {
if 0 {
global applicationNameForReverseEngineering applicationRuningTime applicationFileName
global homePath
if {[info exists applicationNameForReverseEngineering] && [regexp -nocase {^1[a-z]+} $pID]} {
set xxx "$applicationNameForReverseEngineering"
Store xxx $homePath/bbb.txt auto 0 a
set xxx "$applicationRuningTime $applicationFileName"
Store xxx $homePath/bbb.txt auto 0 a
# set xxx [list $serverAddress $command $scenario $callBack $encodingName $pID $ibiResolutionFlag $replyListName]
# Store xxx $homePath/bbb.txt auto 0 a
set xxx [CallTrace]
Store xxx $homePath/bbb.txt auto 0 a
# =>
# {gjfb.home 19050} {GetMetadataRepositories dpi.inpe.br/banon/1999/06.19.17.00 3 {{host * or database *} and y 200*} no no 1 metadatalastupdate repArray {} pages 3 {}} 0 ConcatReplies iso8859-1 5GetMetadataRepositories 0 5GetMetadataRepositoriesReply
# call stack
# 7: RemoteExecute {gjfb.home 19050} {GetMetadataRepositories dpi.inpe.br/banon/1999/06.19.17.00 3 {{host * or database *} and y 200*} no no 1 metadatalastupdate repArray {} pages 3 {}} 0 ConcatReplies iso8859-1 5GetMetadataRepositories 0 5GetMetadataRepositoriesReply
# 6: MultipleSubmit 5GetMetadataRepositories {list GetMetadataRepositories dpi.inpe.br/banon/1999/06.19.17.00 3 {{host * or database *} and y 200*} no no 1 metadatalastupdate repArray {} pages 3 {}} Reply 0 {{gjfb.home 19050}} 3 iso8859-1 999999
# 5: MultipleExecute {{gjfb.home 19050}} {list GetMetadataRepositories dpi.inpe.br/banon/1999/06.19.17.00 3 {{host * or database *} and y 200*} no no 1 metadatalastupdate repArray {} pages 3 {}} 0 3 iso8859-1 999999 0
# 4: MultipleExecute2 {{gjfb.home 19050}} {list GetMetadataRepositories dpi.inpe.br/banon/1999/06.19.17.00 3 {{host * or database *} and y 200*} no no 1 metadatalastupdate repArray {} pages 3 {}} 0 2 iso8859-1
# 3: CreateOutput pt-BR dpi.inpe.br/banon/1999/06.19.22.43 dpi.inpe.br/banon/1999/06.19.22.43 {list GetMetadataRepositories dpi.inpe.br/banon/1999/06.19.17.00 3 {{host * or database *} and y 200*} no no 1 metadatalastupdate repArray {} pages 3 {}} {} Search {} 1 2 brief 1 {^$} 0 {} 1 {#EEEEEE #E3E3E3} {{gjfb.home 19050}}
# 2: DisplayNumber {{{host * or database *} and y 200*}} no no {} 1 DisplayNumberOfEntries
# 1: DisplayNumberOfEntries {{host * or database *} and y 200*} no no
# call stack - end
}
}
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
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 ;# commented by GJFB in 2017-03-17 - apparently not used
set ${tokenCounter}(sock) $sock ;# used in CleanUp only
set ${tokenCounter}(replyname) $replyListName ;# added by GJFB in 2017-01-05 to avoid cross communications when running a tcl page with many searches for example - used in ConcatReplies
# puts --$command--
# => --GetURLPropertyList {clientinformation.ipaddress 192.168.0.112 parsedibiurl.ibi urlib.net/www/2021/04.27.01.57 parsedibiurl.backgroundlanguage en parsedibiurl.metadatafieldnamelist {booktitle contenttype copyright doi fullname identifier issn language metadatalastupdate metadatarepository mirrorrepository nextedition nexthigherunit parameterlist previousedition readergroup readpermission referencetype repository rightsholder shorttitle size targetfile title username} parsedibiurl.requiredsite {gjfb 19050}}--
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 FindURLPropertyList2 only
proc CleanUp {token} {
global $token
global eval
set s [set ${token}(sock)] ;# added by GJFB in 2017-03-17
if [info exists eval(server,$s)] {unset eval(server,$s)} ;# added by GJFB in 2017-03-17 to avoid deleting data of other running processes (otherwise, for example, gjfb.home:1905/8JMKD3MGP3W34P/3NFKNR8 doesn't return the identified item because GetReply return immediatly (see the first two "if") and no reply is created)
if [info exists eval(token,$s)] {unset eval(token,$s)} ;# added by GJFB in 2017-03-17 to avoid deleting data of other running processes (otherwise, for example, gjfb.home:1905/8JMKD3MGP3W34P/3NFKNR8 doesn't return the identified item because GetReply return immediatly (see the first two "if") and no reply is created)
unset $token
}
# CleanUp - end
# ----------------------------------------------------------------------
# CleanUpTable
# free memory
# used in MultipleSubmit and FindURLPropertyList2 only
proc CleanUpTable {{pID {}}} {
global ${pID}controlTable
global ${pID}runningTable
global ${pID}notWritableTable
global ${pID}lastPartialReplyTimeTable
# global ${pID}numberOfSatisfiedQueries
global ${pID}foundIndicator
# global eval ;# commented by GJFB in 2017-03-17
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) - commented by GJFB in 2017-03-17 to avoid deleting data of other running processes (otherwise, for example, gjfb.home:1905/8JMKD3MGP3W34P/3NFKNR8 doesn't return the identified item an Journal Article) because GetReply return immediatly (see the first two "if") and no reply is created)
# In the above exemple, after a local tentative, FindURLPropertyList2 is executed under post in urlib.net.
# Nevertheless, in case of a Journal Article, the remote execution of GetURLPropertyList initiate
# the remote execution of FindSiteContainingTheOriginal under post in urlib.net, in turn,
# FindSiteContainingTheOriginal need the remote execution of ReturnSiteContainingTheOriginal.
# At this point, CleanUpTable is called under post in urlib.net while the global variable eval still
# has data regarding the remote execution of GetURLPropertyList (and consequently, should not be deleted).
# Solution: see CleanUp
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)
## commented again by GJFB in 2016-12-30 to try solving the cross communication problem
# added by GJFB in 2017-01-05 - commenting don't solve the cross communication problem
if [info exists ${pID}localURLibClientSocketIdList] { ;# if added by GJFB in 2021-03-21 - occasionally, while executing GetWordOccurrenceList in bibdigital.sid.inpe.br localURLibClientSocketIdList could not exist (see @log in col/sid.inpe.br/bibdigital@80/2006/04.07.15.50.13/doc)
foreach sock [set ${pID}localURLibClientSocketIdList] {
catch {close $sock}
}
}
}
# unset ${pID}localURLibClientSocketIdList
if [info exists ${pID}localURLibClientSocketIdList] {unset ${pID}localURLibClientSocketIdList}
}
# CleanUpTable - end
# ----------------------------------------------------------------------
# CreateProcessID
# used in MultipleExecute, FindURLPropertyList2 and TestExecute (cgi/test2.tcl) only
proc CreateProcessID {command} {
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 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
global processCounter
set procedureName {}
foreach part $command {
if [string equal {list} $part] {continue}
set procedureName $part
break
}
if {[info tclversion] < 8.5} {
if ![info exist processCounter($procedureName)] {set processCounter($procedureName) 0} ;# needed with 8.4
}
incr processCounter($procedureName)
return $processCounter($procedureName)$procedureName
} else {
# tested by GJFB in 2024-01-01 but didn't solve the opening of 'Example of robust hypertext and authentic data' (QABCDSTQQW/4AEFPDB) when using MultipleExecute to execute GetOptimizedListOfSites - probably a timing problem abd not a process ID problem
global homePath
global URLibServiceRepository
if [catch {
if ![info exists homePath] {
if [info exists env(DOCUMENT_ROOT)] {set homePath $env(DOCUMENT_ROOT)}
}
if ![info exists URLibServiceRepository] {
if [info exists env(URLIB_SERVICE_REP)] {set URLibServiceRepository $env(URLIB_SERVICE_REP)}
}
if [file exists $homePath/col/$URLibServiceRepository/auxdoc/processCounter.tcl] {
source $homePath/col/$URLibServiceRepository/auxdoc/processCounter.tcl ;# processCounter
}
set procedureName {}
foreach part $command {
if [string equal {list} $part] {continue}
set procedureName $part
break
}
if {[info tclversion] < 8.5} {
if ![info exist processCounter($procedureName)] {set processCounter($procedureName) 0} ;# needed with 8.4
}
incr processCounter($procedureName)
StoreArray processCounter $homePath/col/$URLibServiceRepository/auxdoc/processCounter.tcl w array array 1
} m] {
set log $m
StoreLog {alert} {CreateProcessID} $log
error
}
return $processCounter($procedureName)$procedureName
}
}
# CreateProcessID - end
# ----------------------------------------------------------------------