. Access in: 2023, Dec. 18.
proc CreatePermissionList {mirrorRepList} {
# runs with post
global col
global environmentArray
global loCoInRep ;# used when sourcing $col/$parentRepository/doc/displayControl.tcl
global homePath ;# used when sourcing $col/$parentRepository/doc/displayControl.tcl
global mirrorHomePageRepository ;# added by GJFB in 2022-10-10
# puts $mirrorRepList
if {[llength $mirrorRepList] != 1} {
foreach item [array names environmentArray *,permissionList] {
unset environmentArray($item)
}
foreach item [array names environmentArray *,languagePreference] {
unset environmentArray($item)
}
foreach item [array names environmentArray *,displayReviewButton] {
unset environmentArray($item)
}
}
source $col/$mirrorHomePageRepository/doc/displayControl.tcl ;# added by GJFB in 2022-10-10 required to set the list referenceTypeList that migth be used in some sources below, for example when sourcing col/iconet.com.br/banon/2003/05.31.10.26/doc/displayControl.tcl
foreach mirrorRep $mirrorRepList {
# puts $mirrorRep
# controlArray.tcl in doc customizes displayControl.tcl in doc
# displayControl.tcl in auxdoc customizes controlArray.tcl in doc
# auxdoc/displayControl.tcl should be used in place of auxdoc/@writePermission.tcl
set parentRepository [lindex [GetCitedRepositoryList $mirrorRep] 0]
# puts 1-$parentRepository
# => 1-dpi.inpe.br/banon/2000/01.23.20.24
if [info exists languagePreference] {unset languagePreference}
if ![info exists permissionListArray($parentRepository)] {
if [file exists $col/$parentRepository/doc/displayControl.tcl] {
set log "sourcing col/$parentRepository/doc/displayControl.tcl"
StoreLog {notice} {CreatePermissionList} $log
# SOURCE displayControl.tcl - may set permissionList, languagePreference and displayReviewButton
if [catch {source $col/$parentRepository/doc/displayControl.tcl}] {
global errorInfo
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] CreatePermissionList (1): error while sourcing:\ncol/$parentRepository/doc/displayControl.tcl\n$errorInfo\n"
puts $log
Store log $homePath/@errorLog auto 0 a
} else {
if [info exists displayTable] {unset displayTable} ;# free memory location
# set environmentArray($mirrorRep,permissionList) $permissionList
# environmentArray
ConditionalSet environmentArray($mirrorRep,permissionList) permissionList {}
# ConditionalSet environmentArray($mirrorRep,languagePreference) languagePreference en
ConditionalSet environmentArray($mirrorRep,languagePreference) languagePreference {}
ConditionalSet environmentArray($mirrorRep,displayReviewButton) displayReviewButton 1
set permissionListArray($parentRepository) $environmentArray($mirrorRep,permissionList)
set languagePreferenceArray($parentRepository) $environmentArray($mirrorRep,languagePreference)
set displayReviewButtonArray($parentRepository) $environmentArray($mirrorRep,displayReviewButton)
}
}
} else {
# added by GJFB in 2013-01-09 to avoid sourcing more than once
set environmentArray($mirrorRep,permissionList) $permissionListArray($parentRepository)
set environmentArray($mirrorRep,languagePreference) $languagePreferenceArray($parentRepository)
set environmentArray($mirrorRep,displayReviewButton) $displayReviewButtonArray($parentRepository)
}
foreach parentRepository [GetCitedRepositoryList $parentRepository] {
# puts 2-$parentRepository
# => 2-dpi.inpe.br/banon/1999/05.03.22.11
# SUBMISSION FORM
if [TestContentType $parentRepository {Submission Form}] {
if ![info exists permissionListArray($parentRepository)] {
if [file exists $col/$parentRepository/doc/displayControl.tcl] {
set log "sourcing col/$parentRepository/doc/displayControl.tcl"
StoreLog {notice} {CreatePermissionList} $log
# SOURCE displayControl.tcl - may set permissionList, languagePreference and displayReviewButton
if [catch {source $col/$parentRepository/doc/displayControl.tcl}] {
global errorInfo
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] CreatePermissionList (2): error while sourcing:\ncol/$parentRepository/doc/displayControl.tcl\n$errorInfo\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
if [info exists displayTable] {unset displayTable} ;# free memory location
if [file exists $col/$parentRepository/doc/controlArray.tcl] {
if [file exists $col/$parentRepository/doc/controlArray.tcl] {
set log "sourcing col/$parentRepository/doc/controlArray.tcl"
StoreLog {notice} {CreatePermissionList} $log
if [catch {source $col/$parentRepository/doc/controlArray.tcl}] {
global errorInfo
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] CreatePermissionList (3): error while sourcing:\ncol/$parentRepository/doc/controlArray.tcl\n$errorInfo\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
foreach index [array names controlArray] {
set $index $controlArray($index)
}
}
if [file exists $col/$parentRepository/auxdoc/@writePermission.tcl] {
set log "sourcing col/$parentRepository/auxdoc/@writePermission.tcl"
StoreLog {notice} {CreatePermissionList} $log
if [catch {source $col/$parentRepository/auxdoc/@writePermission.tcl}] {
global errorInfo
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] CreatePermissionList (4): error while sourcing:\ncol/$parentRepository/auxdoc/@writePermission.tcl\n$errorInfo\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
if [file exists $col/$parentRepository/auxdoc/displayControl.tcl] {
set log "sourcing col/$parentRepository/doc/auxdoc/displayControl.tcl"
StoreLog {notice} {CreatePermissionList} $log
if [catch {source $col/$parentRepository/auxdoc/displayControl.tcl}] {
global errorInfo
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] CreatePermissionList (5): error while sourcing:\ncol/$parentRepository/auxdoc/displayControl.tcl\n$errorInfo\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
# environmentArray
ConditionalSet environmentArray($mirrorRep,permissionList) permissionList {}
# ConditionalSet environmentArray($mirrorRep,languagePreference) languagePreference en ;# commented by GJFB in 2023-12-18
ConditionalSet environmentArray($mirrorRep,languagePreference) languagePreference {} ;# added by GJFB in 2023-12-18 to allow the use of the browser language preference
# puts "$mirrorRep $environmentArray($mirrorRep,languagePreference)"
ConditionalSet environmentArray($mirrorRep,displayReviewButton) displayReviewButton 1
set permissionListArray($parentRepository) $environmentArray($mirrorRep,permissionList)
set languagePreferenceArray($parentRepository) $environmentArray($mirrorRep,languagePreference)
set displayReviewButtonArray($parentRepository) $environmentArray($mirrorRep,displayReviewButton)
break
} else {
set environmentArray($mirrorRep,permissionList) $permissionListArray($parentRepository)
set environmentArray($mirrorRep,languagePreference) $languagePreferenceArray($parentRepository)
set environmentArray($mirrorRep,displayReviewButton) $displayReviewButtonArray($parentRepository)
}
}
}
}
}
# CreatePermissionList - end
# ----------------------------------------------------------------------
# CreateOrderingTable
# this ordering table is computed from the one in referRepository
# it is used in the FieldCompare procedure (utilitiesMirror.tcl)
proc CreateOrderingTable {} {
global referRepository
global ${referRepository}::conversionTable
# global multipleLineReferFieldNamePattern
global multipleLineReferFieldNamePattern2
global firstFieldNameList
# foreach index [array names conversionTable *,%*] #
foreach index [array names conversionTable] {
set fieldName $conversionTable($index) ;# author
if {$fieldName == {}} {continue}
regexp {(.*),(%.*)} $index m referenceType referFieldName
# set orderingTable($referenceType,$fieldName) [set ${referRepository}::orderingTable($referFieldName)] ;# commented by GJFB in 2020-11-18
set orderingTable($referenceType,$fieldName) [set ${referRepository}::orderingTable($referenceType,$referFieldName)] ;# added by GJFB in 2020-11-18 to allow organizing Full Entry by reference type (see refer repository)
if 1 {
# could be commented after a long period, once files like .repArray.tcl have been recreated - it is a way to reduce the size of fsuch files since, for exampe, isbn doesn't have firstisbn
# if [regexp {%A|%E|%Y|%\?|%@group|%@affiliation|%@electronicmailaddress} $referFieldName]
# if [regexp $multipleLineReferFieldNamePattern $referFieldName] # ;# commented by GJFB in 2018-01-07
if [regexp $multipleLineReferFieldNamePattern2 $referFieldName] { ;# added by GJFB in 2018-01-07 to exclude nexthigerunit and previous lowerunit
## add FIRST for some multiple line fields
# add FIRST for multiple line fields
# set orderingTable($referenceType,first$fieldName) [set ${referRepository}::orderingTable($referFieldName)] ;# commented by GJFB in 2020-11-18
set orderingTable($referenceType,first$fieldName) [set ${referRepository}::orderingTable($referenceType,$referFieldName)] ;# added by GJFB in 2020-11-18 to allow organizing Full Entry by reference type (see refer repository)
}
} else {
# not yet in use
# added by GJFB in 2022-07-25
# add FIRST
if {[lsearch $firstFieldNameList first$fieldName] != -1} {
set orderingTable($referenceType,first$fieldName) [set ${referRepository}::orderingTable($referenceType,$referFieldName)] ;# added by GJFB in 2020-11-18 to allow organizing Full Entry by reference type (see refer repository)
}
}
}
return [array get orderingTable] ;# {Misc,author 4 Misc,title 5}
}
# CreateOrderingTable - end
# ----------------------------------------------------------------------
# FindTheMostRecentReferences
# used in UpdateTheMostRecent (in Search.tcl) only
## excludes all the parent repositories of the URLibService
# excludes all the hidden repositories
# removeTheOldest value is 0 or 1
# 1 means to remove the oldest entries (used by UpdateTheMostRecent)
# justFullTexts value is 0 or 1
# 1 means to consider just full texts
# Example:
# FindTheMostRecentReferences mostRecentReferences 10 0 1
# =>
# iconet.com.br/banon/2001/07.27.00.56.36-0,metadatalastupdate {2001:08.07.18.31.04 dpi.inpe.br/banon/1999/01.09.22.14}
proc FindTheMostRecentReferences {arrayName maximumNumberOfEntries {justFullTexts 0} {removeTheOldest 0}} {
# runs with post
global metadataArray
upvar #0 $arrayName metadataArray2 ;# may be metadataArray or mostRecentReferences or mostRecentFullTexts
# set xxx [CallTrace]
# Store xxx C:/tmp/bbb auto 0 a
# =>
# call stack
# 7: FindTheMostRecentReferences mostRecentReferences 10 0 1
# 6: UpdateTheMostRecent mostRecentReferences
# 5: dpi.inpe.br/banon/1999/04.21.17.06::CreateRepArray ...
# 4: UpdateMetadata ...
# 3: UpdateCollection {urlib.net/www/2016/06.14.22.58 urlib.net/www/2016/06.14.22.58.50}
# 2: UpdateRepMetadataRep ...
# 1: ServeLocalCollection sock800 192.168.0.102 60439
# call stack - end
set list {}
foreach {index stamp} [array get metadataArray2 *,metadatalastupdate] {
# puts $index
# => urlib.net/www/2021/03.06.22.00.48-0,metadatalastupdate
# if [regsub -- {-0[^-]*$} $index {} metadataRep] #
# if [regsub -- {-0$} $index {} metadataRep] # ;# commented by GJFB in 2021-03-25 programming error
if [regsub -- {-0.*$} $index {} metadataRep] { ;# added by GJFB in 2021-03-25
# keep only the -0 references
if {[info exists metadataArray($metadataRep-0,visibility)] && \
[string compare {shown} $metadataArray($metadataRep-0,visibility)] == 0} {
# keep only the visible references
if $justFullTexts {
regsub {,.*} $index {} rep-i
if [info exists metadataArray(${rep-i},size)] {
# keep only the references having a full text
lappend list [list $index $stamp]
}
} else {
lappend list [list $index $stamp]
}
}
}
}
# compare stamp
set list [lsort -command Compare10- $list]
if $removeTheOldest {
unset metadataArray2
}
return [join [lrange $list 0 [expr $maximumNumberOfEntries - 1]]]
}
# FindTheMostRecentReferences - end
# ----------------------------------------------------------------------
# FindTheMostRecentReferences2
# a more efficient coding when there is no need to remove the oldest
# used in GetMostRecentMetadataRep and UpdateTheMostRecent (in Search.tcl) only
proc FindTheMostRecentReferences2 {maximumNumberOfEntries {justFullTexts 0}} {
# runs with post
global metadataArray
global repArray
set list {}
set i 1
foreach index [lsort -decreasing [array names repArray *:??.??.??.??.??,metadatalastupdate]] {
foreach rep-i $repArray($index) {
if [regexp -- {-0$} ${rep-i}] {
# keep only the -0 references
set rep-0 ${rep-i}
if {[info exists metadataArray(${rep-0},visibility)] && \
[string compare {shown} $metadataArray(${rep-0},visibility)] == 0} {
# keep only the visible references
if $justFullTexts {
if [info exists metadataArray(${rep-0},size)] {
# keep only the references having a full text
set list [concat $list [list ${rep-0},metadatalastupdate $metadataArray(${rep-0},metadatalastupdate)]]
if {$i == $maximumNumberOfEntries} {return $list}
incr i
}
} else {
set list [concat $list [list ${rep-0},metadatalastupdate $metadataArray(${rep-0},metadatalastupdate)]]
if {$i == $maximumNumberOfEntries} {return $list}
incr i
}
}
}
}
}
return $list
}
# FindTheMostRecentReferences2 - end
# ----------------------------------------------------------------------
# Compare10-
# used to compare stamp in FindTheMostRecentReferences
proc Compare10- {a b} {
set a10 [lindex [lindex $a 1] 0]
set b10 [lindex [lindex $b 1] 0]
return [string compare $b10 $a10]
}
# Compare10- - end
# ----------------------------------------------------------------------
# LoadBannerPathArray
proc LoadBannerPathArray {} {
# runs with post
global bannerSequenceRepList
global URLibBannerSequenceRepository
global bannerPathArray
global col
# get the first encountered
set bannerSequenceRep [lindex $bannerSequenceRepList 0]
if {$bannerSequenceRep == "$URLibBannerSequenceRepository" && \
[llength $bannerSequenceRepList] > 1} {
set bannerSequenceRep [lindex $bannerSequenceRepList 1]
}
if [file exists $col/$bannerSequenceRep/doc/@bannerSequence.tcl] {
# bannerPathArray (set in @bannerSequence.tcl)
catch {source $col/$bannerSequenceRep/doc/@bannerSequence.tcl}
}
}
# LoadBannerPathArray
# ----------------------------------------------------------------------
# StoreHostCollection
proc StoreHostCollection {rep hostCollection} {
# runs with start and post
set var $hostCollection
StoreService var $rep hostCollection 1 1
}
if 0 {
# testing
set col ../../../../..
source utilities1.tcl
StoreHostCollection dpi.inpe.br/banon/2000/05.25.20.06 dpi.inpe.br/banon/1999/01.09.22.14
StoreHostCollection dpi.inpe.br/banon-pc2@80/2009/03.13.22.03 {dpi.inpe.br/banon/1999/01.09.22.14
dpi.inpe.br/banon/2003/12.10.19.30
dpi.inpe.br/banon/1999/01.09.22.14} ;# old data format
}
# StoreHostCollection - end
# ----------------------------------------------------------------------
# LoadHostCollection
# return an empty list if the hostCollection file was corrupted
proc LoadHostCollection {rep} {
LoadService $rep hostCollection data 1 1
return $data
}
if 0 {
# testing
set col ../../../../..
source cgi/mirrorfind-.tcl
source utilities1.tcl
source utilitiesStart.tcl
set homePath {C:/Users/geral/OneDrive/URLib 2}
puts [LoadHostCollection dpi.inpe.br/banon/1999/05.03.22.11]
puts [LoadHostCollection iconet.com.br/banon/2000/12.30.22.40]
puts [LoadHostCollection dpi.inpe.br/banon-pc2@80/2009/03.13.22.03]
puts [LoadHostCollection dpi.inpe.br/banon-pc@1905/2005/02.19.00.40]
puts [LoadHostCollection sid.inpe.br/gprb0705/2024/07.12.17.09]
puts [LoadHostCollection iconet.com.br/banon/2003/05.31.10.26]
}
# LoadHostCollection - end
# ----------------------------------------------------------------------
# FindInternetAddress
#
# Finds host name, domain name and ip address
# used in post and start
proc FindInternetAddress {} {
# runs with start and post
global tcl_platform
global environmentArray
global installInitialCollection
global serverAddress
global serverAddressWithIP
if {$tcl_platform(platform) == "windows"} {
# exec ping -n 1 localhost > ../auxdoc/pingMessage
exec ping -4 -n 1 localhost > ../auxdoc/pingMessage ;# added by GJFB in 2010-10-01 - force IPv4
# Pinging banon-pc2 [127.0.0.1] with 32 bytes of data: ...
# Disparando gjfb [127.0.0.1] com 32 bytes de dados: ...
Load ../auxdoc/pingMessage fileContent
# serverName
# regexp {([^ ]*) \[([^\]]*)\]} $fileContent m serverName ipAddress
regexp {([^ ]*) \[[^\]]*\]} $fileContent m serverName ;# banon-pc2
# puts --$serverName--
# hostName
set hostName [info hostname]
# puts --$hostName--
if [string equal {localhost} $serverName] {set serverName $hostName}
# domainName
set domainName {}
if ![string equal {} $hostName] {
if ![regexp "^$hostName\.(.*)$" $serverName m domainName] {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
# regexp {^([^\.]*)\.(.*)$} $serverName m hostName domainName
regexp {^(.*?)\.(.*)$} $serverName m hostName domainName
}
} else {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
# regexp {^([^\.]*)\.(.*)$} $serverName m hostName domainName
regexp {^(.*?)\.(.*)$} $serverName m hostName domainName
}
if [string equal {} $hostName] {
set message {host name not found}
Store message ../auxdoc/messageForStart
exit
}
# Store serverName C:/tmp/bbb auto 0 a
# exec ping -n 1 $serverName > ../auxdoc/pingMessage
exec ping -4 -n 1 $serverName > ../auxdoc/pingMessage ;# added by GJFB in 2010-10-01 - force IPv4
# Pinging banon-pc2 [150.163.2.174] with 32 bytes of data: ...
# Pinging banon-pc2 [192.168.1.6] with 32 bytes of data: ...
# Pinging banon-pc2 [127.0.0.1] with 32 bytes of data: ...
# Pinging banon-pc3 [192.168.1.100] with 32 bytes of data: ...
# Disparando gjfb [fe80::2c34:2cb0:4033:511%8] com 32 bytes de dados: ...
Load ../auxdoc/pingMessage fileContent
# ipAddress
regexp {\[([^\]]*)\]} $fileContent m ipAddress
if ![info exists ipAddress] {
set message {ip address not found}
Store message ../auxdoc/messageForStart
exit
}
}
if {$tcl_platform(platform) == "unix"} {
if {$tcl_platform(os) == "Linux"} {
# Linux
# serverName
if [catch {exec ping -c 1 localhost > ../auxdoc/pingMessage}] {
# ping: unknown host localhost
# message gotten from licari.ibict.br
set serverName localhost
} else {
# PING banon-pc3 (127.0.0.1) 56(84) bytes of data. ...
# PING netuno.dpi.inpe.br (127.0.0.1) 56(84) bytes of data. ...
# PING mtc-m18 (127.0.0.1) 56(84) bytes of data. ...
# PING localhost.localdomain (127.0.0.1) 56(84) bytes of data. ...
# PING localhost (127.0.0.1) 56(84) bytes of data. ...
# PING mtc-m22 (127.0.0.1) 56(84) bytes of data. ...
Load ../auxdoc/pingMessage fileContent
# regexp {([^ ]*) \(([^\)]*)\)} $fileContent m serverName ipAddress
regexp {([^ ]*) \([^\)]*\)} $fileContent m serverName ;# netuno.dpi.inpe.br, localhost, mtc-m22
}
# hostName
set hostName [info hostname] ;# netuno.dpi.inpe.br mtc-m18, urlibservice.eng.REGISTRO.br, mtc-m22
# if [string equal {localhost} $serverName] {set serverName $hostName} ;# use hostName
if [regexp {^localhost} $serverName] {set serverName $hostName} ;# use hostName - added by GJFB in 2014-11-01 - now ping might return localhost.localdomain instead of just localhost
# domainName
set domainName {}
if ![string equal {} $hostName] {
if ![regexp "^$hostName\.(.*)$" $serverName m domainName] {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
# regexp {^([^\.]*)\.(.*)$} $serverName m hostName domainName
regexp {^(.*?)\.(.*)$} $serverName m hostName domainName
}
} else {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
# regexp {^([^\.]*)\.(.*)$} $serverName m hostName domainName
regexp {^(.*?)\.(.*)$} $serverName m hostName domainName
}
if [string equal {} $hostName] {
set message {host name not found}
Store message ../auxdoc/messageForStart
exit
}
# exec ping -c 1 $serverName > ../auxdoc/pingMessage ;# commented by GJFB in 2024-10-14
if [catch {exec ping -c 1 $serverName > ../auxdoc/pingMessage} m] { ;# catch added by GJFB in 2024-10-14 - useful when ping returns 100% packet loss
puts [StoreLog alert FindInternetAddress "$m while executing 'ping -c 1 $serverName'"]
exit
}
# PING hermes2.dpi.inpe.br (150.163.2.23) 56(84) bytes of data. ...
# PING netuno.dpi.inpe.br (127.0.0.1) 56(84) bytes of data. ...
# PING mtc-m18 (127.0.0.1) 56(84) bytes of data. ...
# PING bibdigital.sid.inpe.br (150.163.34.247) 56(84) bytes of data.
# PING urlibservice.eng.registro.br (2001:12ff:0:7::168) 56 data bytes
Load ../auxdoc/pingMessage fileContent
# ipAddress
regexp {\(([^\)]*)\)} $fileContent m ipAddress
if ![info exists ipAddress] {
set message {ip address not found}
Store message ../auxdoc/messageForStart
exit
}
} else {
# SunOS
set hostName [exec hostname]
if [string equal {} $hostName] {
set message {host name not found}
Store message ../auxdoc/messageForStart
exit
}
if [catch {ReturnFullServerNameIP $hostName} output] {
Load ../auxdoc/domainName.txt domainName
Load ../auxdoc/ipAddress.txt ipAddress
} else {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
regsub {\..*$} $hostName {} hostName ;# gemini.dpi.inpe.br -> gemini
foreach {fullServerName ipAddress} $output {break}
set domainName {}
# regexp "^$hostName\.(.*)" [lindex $itemList2 2] m domainName
regexp "^$hostName\.(.*)" $fullServerName m domainName
# set ipAddress [lindex $itemList2 3]
}
if [string equal {} $ipAddress] {
set message {ip address not found}
Store message ../auxdoc/messageForStart
exit
}
}
}
# Trying to find the domain name using nslookup
if [string equal {127.0.0.1} $ipAddress] {
foreach {fullServerName ipAddress} [ReturnFullServerNameIP $serverName] {break}
if [string equal {} $ipAddress] {
set ipAddress {127.0.0.1}
} else {
if [string equal {} $domainName] {
if ![regexp "^$hostName\.(.*)$" $fullServerName m domainName] {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
# regexp {^[^\.]*\.(.*)$} $fullServerName m domainName
regexp {^.*?\.(.*)$} $fullServerName m domainName
}
}
}
} else {
# puts --$domainName--
# => {}
if [string equal {} $domainName] {
foreach {fullServerName ip} [ReturnFullServerNameIP $serverName] {break}
# foreach {fullServerName ip} [ReturnFullServerNameIP $ipAddress] {break} ;# added by GJFB in 2012-07-01 - the domain name may be found using the ipAddress instead of the serverName - useful at c94a96c1.virtua.com.br <- this URL doesn't work (server not found)
# ip not used
# puts --$serverName--
# => gjfb
# puts --$hostName--
# => gjfb
# puts --$fullServerName--
# => gjfb.Home
if ![regexp "^$hostName\.(.*)$" $fullServerName m domainName] {
# >>> here it is assumed that the complete host name without domain doesn't contain any periods (.)
# regexp {^[^\.]*\.(.*)$} $fullServerName m domainName
regexp {^.*?\.(.*)$} $fullServerName m domainName
}
}
}
# puts --$domainName--
# => Home
# Trying to find the domain name using nslookup - end
# >>> environmentArray(hostName) and environmentArray(domainName) might be fixed in post for dynamic IP
# in the example above, hostName becomes gjfb.home and domainName becomes {}
# OBS: environmentArray(hostName) is not the name of the virtual host (if any), it is just the computer name
# OBS: environmentArray(domainName) is used in GetServerAddress
# set environmentArray(hostName) $hostName
set environmentArray(hostName) [string tolower $hostName] ;# because rep is case-insensitive and because of env(PATH_INFO) that might contain the path info in lower case
set environmentArray(domainName) [string tolower $domainName] ;# because rep is case-insensitive (security issue - normaly should not be necessary)
set environmentArray(ipAddress) $ipAddress
# StoreArray environmentArray ../auxdoc/.environmentArray.tcl
# StoreArray environmentArray ../auxdoc/.environmentArray2.tcl ;# backup
# StoreArrayWithBackup environmentArray ../auxdoc/.environmentArray.tcl ;# added by GJFB in 2010-08-05
StoreArrayWithBackup environmentArray ../auxdoc/.environmentArray.tcl w list ;# added by GJFB in 2010-08-05
# puts [list $hostName $domainName $ipAddress]
# Update serverAddress and serverAddressWithIP
# update both based on environmentArray
# added by GJFB in 2016-06-29 - avoids the need of a second post round when posting from a new Internet address
# puts >>>$environmentArray(ipAddress)
# puts >>>$serverAddressWithIP
if ![string equal $environmentArray(ipAddress) $serverAddressWithIP] {
# if !$installInitialCollection # ;# commented by GJFB in 2021-12-09 to have a nonempty serverAddressWithIP at installation when displaying "posting the URLib local collection at <$serverAddressWithIP>..." in post
set serverAddress [GetServerAddress] ;# banon-pc2.dpi.inpe.br 800
set serverAddressWithIP [GetServerAddress 1]
# #
}
# Update serverAddress and serverAddressWithIP - end
}
# FindInternetAddress - end
# ----------------------------------------------------------------------
# ConvertHex
# used in FindInternetAddress for Windows 2000
proc ConvertHex {string1} {
foreach {character x} [split $string1 {}] {append string2 $character}
regsub -all {\\\n\n } $string2 {} string3
regsub {\n\n$} $string3 {} string3
regsub -all {,00} $string3 {} string3
foreach number [split $string3 ,] {
append string4 [binary format H2 $number]
}
return $string4
}
# ConvertHex - end
# ----------------------------------------------------------------------
# UpdateMetadataFromBiblioDB
# remove value is 0 or 1
# 1 means just to remove, not to load
# 0 means to load the bibliographic data base
# flag value is 0 or 1
# 0 means to ignore the - signal
# 1 means to take into account the - signal (at the beginning of the file)
# flag is used by Bib2Refer
proc UpdateMetadataFromBiblioDB {rep remove flag} {
# runs with post
# remove
if $remove {
set metadata2List [GetMetadata $rep-*]
# RemoveMetadata $metadata2List ;# commented by GJFB in 2020-08-18
RemoveMetadata2 $metadata2List ;# added by GJFB in 2020-08-18
} else {
# load
LoadBiblioDB $rep $flag
}
}
# UpdateMetadataFromBiblioDB - end
# ----------------------------------------------------------------------
# UpdateMetadataFromBiblioDB2
# remove value is 0 or 1
# 1 means just to remove, not to load
# 0 means to load the bibliographic data base
# flag value is 0 or 1
# 0 means to ignore the - signal
# 1 means to take into account the - signal (at the beginning of the file)
# flag is used by Bib2Refer
proc UpdateMetadataFromBiblioDB2 {rep {remove 0} {flag 0}} {
# runs with start
global col
Set updateMetadataFromBiblioDBInUse 1
set log [clock format [clock seconds]]
Store log $col/$rep/doc/@log auto 0 a
set message [Eval UpdateMetadataFromBiblioDB $rep $remove $flag]
if {[regsub -all {^<|>$} $message {} message] == 2} {
set message [join $message \n]
Store message $col/$rep/doc/@log auto 0 a
}
Set updateMetadataFromBiblioDBInUse 0
}
# UpdateMetadataFromBiblioDB2 - end
# ----------------------------------------------------------------------
# LoadBiblioDB
# used in UpdateMetadataFromBiblioDB, UpdateCollection, StartService and Script (Administrator page) only
# flag value is 0 or 1
# 0 means to ignore the - signal
# 1 means to take into account the - signal (at the beginning of the file)
# flag is used by Bib2Refer
proc LoadBiblioDB {rep {flag 0}} {
# runs with post
# runs with cgi-script
# global col
global homePath
global metadataArray
global repositoryProperties ;# to test if running with post or cgi-script
global bib2referRepository
global bibpessoal2referRepository
global isis2referRepository
global inverseTable
global serverAddress
global environmentArray
global multipleLineFieldNameList
# set xxx LoadBiblioDB0
# Store xxx C:/tmp/aaa auto 0 a
set beSelective 0
set reference {}
if [file exists $homePath/col/$rep/doc/@reference.bib] {
Load $homePath/col/$rep/doc/@reference.bib fileContent
# beginWith-
set beginWith- [regexp {^-} $fileContent]
set beSelective [expr $flag && ${beginWith-}]
# source $homePath/col/$bib2referRepository/doc/Bib2Refer.tcl ;# for testing code adjustment
set reference [${bib2referRepository}::Bib2Refer $fileContent $beSelective]
} elseif [file exists $homePath/col/$rep/doc/@reference.refer] {
Load $homePath/col/$rep/doc/@reference.refer reference
} elseif [file exists $homePath/col/$rep/doc/@reference.isis] {
if [file isdirectory $homePath/col/$isis2referRepository] {
Load $homePath/col/$rep/doc/@reference.isis fileContent binary
set reference [${isis2referRepository}::Isis2Refer $fileContent $rep]
}
} elseif [file exists $homePath/col/$rep/doc/a.txt] {
if [file isdirectory $homePath/col/$isis2referRepository] {
Load $homePath/col/$rep/doc/a.txt fileContent binary
set reference [${isis2referRepository}::Isis2Refer $fileContent $rep]
}
} elseif [file exists $homePath/col/$rep/doc/A.txt] {
if [file isdirectory $homePath/col/$isis2referRepository] {
Load $homePath/col/$rep/doc/A.txt fileContent binary
set reference [${isis2referRepository}::Isis2Refer $fileContent $rep]
}
} elseif [file exists $homePath/col/$rep/doc/a.TXT] {
if [file isdirectory $homePath/col/$isis2referRepository] {
Load $homePath/col/$rep/doc/a.TXT fileContent binary
set reference [${isis2referRepository}::Isis2Refer $fileContent $rep]
}
} elseif [file exists $homePath/col/$rep/doc/A.TXT] {
if [file isdirectory $homePath/col/$isis2referRepository] {
Load $homePath/col/$rep/doc/A.TXT fileContent binary
set reference [${isis2referRepository}::Isis2Refer $fileContent $rep]
}
} elseif [file exists $homePath/col/$rep/doc/@reference.bp1] {
if [file isdirectory $homePath/col/$bibpessoal2referRepository] {
Load $homePath/col/$rep/doc/@reference.bp1 fileContent
set reference [${bibpessoal2referRepository}::BibPessoal2Refer $fileContent 0]
}
} elseif [file exists $homePath/col/$rep/doc/@reference.bp2] {
if [file isdirectory $homePath/col/$bibpessoal2referRepository] {
Load $homePath/col/$rep/doc/@reference.bp2 fileContent binary
set reference [${bibpessoal2referRepository}::BibPessoal2Refer $fileContent 1]
}
}
# Store rep C:/tmp/aaa auto 0 a
# Store reference C:/tmp/aaa auto 0 a
ConvertMultipleRefer2MetadataList 1 $reference $rep localMetadataArray ;# sets localMetadataArray
# set metadataList [array get localMetadataArray]
# Store metadataList C:/tmp/bbb.txt auto 0 a
# set numberOfRef [llength [array names localMetadataArray *,referencetype]]
# set numberOfRef [regsub -all {,referencetype} $metadataList {} m]
# array set localMetadataArray $metadataList
# set numberOfRef [llength [array names localMetadataArray *,referencetype]]
# Store numberOfRef C:/tmp/aaa auto 0 a
# set versionStamp [lindex $repositoryProperties($rep,history) end]
if [info exists repositoryProperties] {
# post running
set versionStamp [GetVersionStamp $rep] ;# need repositoryProperties
} else {
# cgi-scrip running
set versionStamp {}
}
# for {set i 1} {$i <= $numberOfRef} {incr i}
if !$beSelective {
# remove
set metadata2List [GetMetadata $rep-*]
# RemoveMetadata $metadata2List ;# commented by GJFB in 2020-08-18
RemoveMetadata2 $metadata2List ;# added by GJFB in 2020-08-18
}
# visibility
LoadService $rep visibility visibility 1 1
if [string equal {} $visibility] {set visibility 0} ;# shown
foreach item [array names localMetadataArray *,index] {
set i $localMetadataArray($item)
set x 0; after 1 {set x 1}; vwait x ;# nice procedure
if $beSelective {
# remove
# set metadata2List [GetMetadata $rep-$i*] ;# commented by GJFB in 2013-06-10 - the comma is missing
set metadata2List [GetMetadata $rep-$i,*] ;# added by GJFB in 2013-06-10
# RemoveMetadata $metadata2List ;# commented by GJFB in 2020-08-18
RemoveMetadata2 $metadata2List ;# added by GJFB in 2020-08-18
}
set index [array names localMetadataArray $rep-$i,metadatarepository]
if ![string equal {} $index] {
# there is a nonempty metadatarepository field (i.e., a metadataRep) in the reference $rep-$i
# example: see Achache reference in id 83LX3pFwXQZeBBx/onedv
# 102
set metadataRep $localMetadataArray($index)
if ![string equal {} $metadataRep] {
if [file isdirectory $homePath/col/$metadataRep] {
# remove
set metadata2List [array get metadataArray $metadataRep-0,*]
# Store metadata2List C:/tmp/aaa auto 0 a
# RemoveMetadata $metadata2List ;# commented by GJFB in 2020-08-18
RemoveMetadata2 $metadata2List ;# added by GJFB in 2020-08-18
# Update @metadata.refer
# (metadata -> refer)
# similar to CreateFullReferEntry
set referenceType $localMetadataArray($rep-$i,referencetype)
# Store referenceType C:/tmp/bbb auto 0 a
# set xxx [array get localMetadataArray $rep-$i,*]
# set xxx [join $xxx \n]
# Store xxx C:/tmp/bbb auto 0 a
set output {}
set targetFile {}
foreach index [array names localMetadataArray $rep-$i,*] {
# value
set value $localMetadataArray($index)
# field
regsub {.*,} $index {} field
# Update localMetadataArray
unset localMetadataArray($index)
set localMetadataArray($metadataRep-0,$field) $value
# Update localMetadataArray - end
if [regexp {^citationkey$|^firstauthor$|^index$|^repository$} $field] {continue}
if [regexp {^targetfile$} $field] {set targetFile $value}
# if [regexp {^author|^editor|^programmer|^reporter|^cartographer|^base|^committee|^translator|^serieseditor|^source|^group|^affiliation|^supervisor} $field]
if {[lsearch -exact $multipleLineFieldNameList $field] != -1} {
# multiple line fields
foreach item $value {
lappend output "$inverseTable($referenceType,$field) $item"
}
} else {
lappend output "$inverseTable($referenceType,$field) $value"
}
}
foreach {repName output} \
[AddTwoFields $metadataRep $referenceType $targetFile $output] \
{break}
# set output [lsort -command ReferFieldCompare $output] ;# now in AddTwoFields
set output [join $output \n]
set path $homePath/col/$metadataRep/doc/@metadata.refer
Load $path fileContent
if ![string equal $output $fileContent] {
# update the @metadata.refer file content
Store output $path
regsub {@.*$} $environmentArray(spMailEntry) {} administratorUserName
# UpdateLastUpdate $metadataRep {}
UpdateLastUpdate $metadataRep {} none $administratorUserName
# MakeDownloadFile $repName 0 1
MakeDownloadFile $repName 0 1 0 $administratorUserName
}
# Update @metadata.refer - end
# Append repName to the repositoryListForStart file content
# (used to update keyRepositoryList in PerformCheck)
Store repName ../auxdoc/repositoryListForStart auto 0 a
# Append repName to the repositoryListForStart file content - end
# UPDATE METADATA
set metadataList {} ;# for add
set metadata2List {} ;# for remove
UpdateMetadataField $metadataRep index 0 metadataList metadata2List
UpdateMetadataField $metadataRep repository $repName metadataList metadata2List
set metadataList [concat $metadataList [CreateExtraFields $metadataRep $serverAddress]]
# set metadataList [concat $metadataList [CreateExtraFields $metadataRep [GetServerAddress]]]
# RemoveMetadata $metadata2List ;# commented by GJFB in 2020-08-18
RemoveMetadata2 $metadata2List ;# added by GJFB in 2020-08-18
array set localMetadataArray $metadataList
# set xxx [CallTrace]
# Store xxx C:/tmp/aaa auto 0 a
# set xxx [array get localMetadataArray $metadataRep-0,*]
# set xxx [join $xxx \n]
# Store xxx C:/tmp/aaa auto 0 a
} else {
# Add the metadatalastupdate and databaserepository fields
set localMetadataArray($rep-$i,metadatalastupdate) $versionStamp
set localMetadataArray($rep-$i,databaserepository) $rep
# Add the metadatalastupdate and databaserepository fields - end
}
} else {
# metadataRep is empty (bibpessoal case)
# Add the metadatalastupdate and databaserepository fields
set localMetadataArray($rep-$i,metadatalastupdate) $versionStamp
set localMetadataArray($rep-$i,databaserepository) $rep
# Add the metadatalastupdate and databaserepository fields - end
}
} else {
# there is no metadataRep in the reference
# Add the metadatalastupdate and databaserepository fields
set localMetadataArray($rep-$i,metadatalastupdate) $versionStamp
set localMetadataArray($rep-$i,databaserepository) $rep
set localMetadataArray($rep-$i,visibility) [expr $visibility?{hidden}:{shown}]
# Add the metadatalastupdate and databaserepository fields - end
}
}
# ADD METADATA
# set metadataList [array get localMetadataArray]
# Store metadataList C:/tmp/aaa auto 0 a
# AddMetadata [array get localMetadataArray] ;# commented by GJFB in 2020-08-18
AddMetadata2 [array get localMetadataArray] ;# added by GJFB in 2020-08-18
}
# LoadBiblioDB - end
# ----------------------------------------------------------------------
# AddTwoFields
# adds the fields targetfile and repName
# targetFile -> repositoryProperties and service/targetFile
# targetFile and repName -> fieldList
# Example:
# AddTwoFields $metadataRep $referenceType $targetFile $fieldList
# used in LoadBiblioDB and LoadMetadata only
proc AddTwoFields {metadataRep referenceType targetFile fieldList} {
# runs with post
# global col
global homePath
global inverseTable
global repositoryProperties
set repName [ReturnRepositoryName $metadataRep]
# Add the targetfile field
if ![string equal {} $targetFile] {
# target file defined in the incoming metadata
set repositoryProperties($repName,targetfile) $targetFile
Store targetFile $homePath/col/$repName/service/targetFile
} else {
# no target file defined in the incoming metadata - use the existing value in repositoryProperties
if [info exists repositoryProperties($repName,targetfile)] {
set targetFile $repositoryProperties($repName,targetfile)
lappend fieldList "$inverseTable($referenceType,targetfile) $targetFile"
}
}
# Add the targetfile field - end
# Add the repository field
lappend fieldList "$inverseTable($referenceType,repository) $repName" ;# "%4 $repName"
set fieldList [lsort -command ReferFieldCompare $fieldList]
# Add the repository field - end
return [list $repName $fieldList]
}
# AddTwoFields - end
# ----------------------------------------------------------------------
# ReturnRepositoryName
# used in StartService
proc ReturnRepositoryName {metadataRep} {
# runs with post
global referenceTable
foreach index [array names referenceTable $metadataRep,*] {
if {$referenceTable($index) != "+"} {
regsub {.*,} $index {} repName
return $repName
}
}
# repName not found
# the referenceTable may have been damaged,
# Update referenceTable
UpdateReferenceTable $metadataRep ;# try to repair referenceTable - uses source/reference to recreate repName
# UpdateReferenceFileForLoCoInRep
# Update referenceTable - end
foreach index [array names referenceTable $metadataRep,*] {
if {$referenceTable($index) != "+"} {
regsub {.*,} $index {} repName
return $repName
}
}
# repName not found
# case of a bibliographic data base (is a set of metadata to no repository)
# returns empty
}
# ReturnRepositoryName - end
# ----------------------------------------------------------------------
# ReturnType
proc ReturnType {metadataArrayName rep-i {level {#0}}} {
# runs with start and post
upvar $level $metadataArrayName metadataArray
return $metadataArray(${rep-i},referencetype)
}
# ReturnType - end
# ----------------------------------------------------------------------
# GetServerAddress
# the ipFlag option is used to compare the server address
# with the result of GetURLibServerAddress
# in InformURLibSystem (this file) and FindBannerPath (utilitiesMirror.tcl)
# and to communicate via socket (using domain name instead of ip leads to: "too many nested evaluations (infinite loop?)")
# the result is always in the form {ipAddress urlibPort}
proc GetServerAddress {{ipFlag 0}} {
# runs with start and post
global environmentArray
# puts [regexp {(.*) +(.*)} $environmentArray(spPortEntry) m httpHostName urlibPortNumber]
if [regexp {(.*) +(.*)} $environmentArray(spPortEntry) m httpHostName urlibPortNumber] {
# environmentArray(spPortEntry) => {banon-pc2 800}
# environmentArray(spPortEntry) => {www.urlib.net 800}
if $ipFlag {
# set ipAddress $environmentArray(ipAddress)
# regsub {.$} $urlibPortNumber {} serverPort ;# drop the last digit
# set serverAddress $ipAddress:$serverPort
set serverName $environmentArray(ipAddress)
} else {
set hostName $httpHostName ;# banon-pc2 or www.urlib.net
if [regexp {\.} $hostName] {
# host name is already a full server name, e.g., www.urlib.net or banon-pc2.dpi.inpe.br
set serverName $hostName
} else {
set domainName $environmentArray(domainName)
if [string equal {} $domainName] {
set serverName $hostName
} else {
set serverName $hostName.$domainName ;# banon-pc2.dpi.inpe.br
}
}
}
set serverAddress [list $serverName $urlibPortNumber] ;# banon-pc2.dpi.inpe.br 800
} else {
# old usage
# environmentArray(spPortEntry) => {80}
# environmentArray(spPortEntry) => {1905}
if $ipFlag {
set serverName $environmentArray(ipAddress)
} else {
set hostName $environmentArray(hostName)
set domainName $environmentArray(domainName)
if [string equal {} $domainName] {
set serverName $hostName
} else {
set serverName $hostName.$domainName
}
}
set portNumber $environmentArray(spPortEntry)
set serverAddress $serverName:$portNumber
set serverAddress [ReturnCommunicationAddress $serverAddress] ;# banon-pc2.dpi.inpe.br:80 -> banon-pc2.dpi.inpe.br 800
}
return $serverAddress
}
# GetServerAddress - end
# ----------------------------------------------------------------------
# CreateNewRepository
# documentType value are empty or default or directory
# empty means to deposit nothing in the new repository
# default means to deposit the document from the default repository
# directory means to deposit a folder document named documentPath
# targetFileOption value is disable or enable
# option value is "copy" or "preserve" or "delete" (see DDRoutine)
# unzip value is 0 or 1; 1 means to unzip the deposited document
# contentType value is Metadata, External Contribution, ...
## copyToSource value is 0 or 1; 1 means to deposit the document into the source as well
# copyToSource value is 0 or 1; 1 means to deposit the document into the source (only)
# userName is the name of the advanced user who is creating the version stamp
# postSubmissionScriptRepList is a list of repositories containing scripts to process
# the submitted files
# $reference ==>
# {%0 Misc} {%@tertiarytype } {%A aa} {%I Deposited in the URLib collection.} {%X aa} {%T tt} {%@secondarykey INPE--/}
# reference is used for post-submission
proc CreateNewRepository {{documentType {empty}} {documentPath {}} \
{targetFileOption disable} {option copy} {unzip 0} {repName {}} \
{fileInfo 1} {contentType {}} {copyToSource 0} {userName {}} \
{postSubmissionScriptRepList {}} {reference {}}} {
# runs with start and post
set argument ""
set argument "$argument -targetfile $targetFileOption"
set argument "$argument -documenttype $documentType"
set argument "$argument -repositorytype new"
set argument "$argument -option $option"
set argument "$argument -reverse 0"
set argument "$argument -documentpath [list $documentPath]"
set argument "$argument -unzip $unzip"
set argument "$argument -fileinfo $fileInfo"
set argument "$argument -contenttype [list $contentType]"
set argument "$argument -copytosource $copyToSource"
set argument "$argument -username [list $userName]" ;# name of the advanced user who is creating the version stamp
set argument "$argument -postsubmissionscriptreplist [list $postSubmissionScriptRepList]"
set argument "$argument -reference [list $reference]"
# set xxx 1-$argument
# Store xxx C:/tmp/aaa auto 0 a
# set return [DDRoutine $argument]
set return [DDRoutine $argument 0 $repName]
if {$return == 1} {return}
if {$return == 0} {return}
return $return
}
# CreateNewRepository - end
# ----------------------------------------------------------------------
# CheckAccess
# used by UpdateRepository2 and UpdateRepMetadataRep
# password must be coded or a session number
# "no advanced user" for the rep is equivalent to "the administrator is the advanced user"
proc CheckAccess {rep userName password} {
# runs with post
global environmentArray
global repositoryProperties
set procedureName [lindex [info level [expr [info level] - 1]] 0]
regsub {@.*$} $environmentArray(spMailEntry) {} administratorUserName
if [info exists repositoryProperties($rep,username)] {
# there is a user with write permission for this repository
if ![regexp "^$repositoryProperties($rep,username)$|^administrator$|^$administratorUserName$" $userName] {
# $userName is neither this user nor the administrator
return "$procedureName: '$userName' has no write permission for the repository $rep"
}
} else {
# there is no user with write permission for this repository
if ![regexp "^administrator$|^$administratorUserName$" $userName] {
# $userName is not the administrator
return "$procedureName: '$userName' has no write permission for the repository $rep"
}
}
if [CheckPassword $userName $password] {
# return "$procedureName: the password is incorrect or the user name doesn't exist"
if [CheckSession $password $userName] {
return "$procedureName: the password is incorrect or the user name doesn't exist, or the session doesn't exist"
} else {
return ;# the session exists
}
}
# the password is correct
}
# CheckAccess - end
# ----------------------------------------------------------------------
# StorePassword2
# Secure version of StorePassword
## used to force a password in processMail in dpi.inpe.br/banon/2005/12.08.20.05
## used only to force a password in cgi/createNewPassword.tcl in iconet.com.br/banon/2009/05.17.20.29
# used only in col/iconet.com.br/banon/2009/05.17.20.29/doc/cgi/createNewPassword.tcl to force the password of an existing user or enter the password of a new user
# ex: is called by cgi/createNewPassword.tcl in urlib.net and run in urlib.net
# Any change in the IBI Network must be reflected in the file col/iconet.com.br/banon/2009/05.17.20.29/auxdoc/conf.tcl in urlib.net
# password and administratorPassword must be coded
# passwordTypeFlag added by GJFB in 2020-10-09 - used to accept new users whose login satisfy the authorizedEmailDomains defined in displayControl.tcl
# passwordTypeFlag value 0 means that the request is for a new password, 1 means the request is for a first password
proc StorePassword2 {userName password administratorPassword {passwordTypeFlag 0}} {
# runs with post
global homePath
global loCoInRep
# Check administrator password
set checkPassordResponse [CheckPassword administrator $administratorPassword]
if $checkPassordResponse {
set checkPassordResponse [CheckPassword passwordmanager $administratorPassword] ;# added by GJFB in 2019-05-28
if $checkPassordResponse {
# if [CheckPassword urlibadm $administratorPassword read] # commented by GJFB in 2018-11-03 - urlibadm is now obsolete
## read is needed because urlibadm is just a read user (he has no full name)
# return "StorePassword2: no administrator or wrong administrator password" ;# commented by GJFB in 2019-05-28
return "StorePassword2: no administrator (or no passwordmanager) or wrong administrator password (or wrong passwordmanager password)" ;# added by GJFB in 2019-05-28
# return "StorePassword2: checkPassordResponse value is $checkPassordResponse, no administrator or wrong administrator password --$administratorPassword--"
# => StorePassword2: checkPassordResponse value is 1, no administrator or wrong administrator password --OfbuXA--.
# #
}
}
# Check administrator password - end
# Waiting for the completion of other authentications
WaitQueue StorePassword2 authentication
# Waiting for the completion of other authentications - end
# Check user name
set return [CheckUsernamePassword $userName {} {} 1 read]
if [string equal {unknown username} $return] {
# new username
if $passwordTypeFlag {
# first password
# added by GJFB in 2020-10-09
set userArray($userName,e-mailaddress) $userName
StoreArray userArray $homePath/col/$loCoInRep/auxdoc/.userArray.tcl w list array 1
} else {
# new password
LeaveQueue StorePassword2 authentication ;# added by GJFB in 2020-11-21
return "StorePassword2: $return"
}
}
# Check user name - end
StorePassword $userName $password
# LeaveQueue [pid] authentication
LeaveQueue StorePassword2 authentication
}
# StorePassword2 - end
# ----------------------------------------------------------------------
# UpdateRepository2
# Secure version of UpdateRepository
# used by Submit (ePrint) and ProcessReview
# password must be coded
proc UpdateRepository2 {
rep metadataRep userName password {documentType {empty}}
{documentPath {}} {targetFileOption disable}
} {
# runs with post
global saveMetadata
set message [CheckAccess $rep $userName $password]
if {[string compare {} $message] != 0} {
return $message
}
# UpdateRepository $rep $documentType $documentPath $targetFileOption
UpdateRepository $rep $documentType $documentPath $targetFileOption copy 0 $userName
# UpdateLastUpdate $rep $metadataRep none
UpdateLastUpdate $rep $metadataRep none $userName
set metadataList {}
set metadata2List {}
if 0 {
# nextUser -> userName
if {[string compare {} $nextUser] != 0} {
StoreService nextUser $rep userName 1 1
UpdateMetadataField $metadataRep username \
$nextUser metadataList metadata2List
}
}
UpdateCrossReferences $rep $metadataRep metadataList metadata2List ;# uses $homePath/col/$rep/service/reference
# UPDATE METADATA (needed to process review)
if 0 {
# commented by GJFB in 2020-08-18
RemoveMetadata $metadata2List
AddMetadata $metadataList
} else {
UpdateMetadata $metadata2List $metadataList ;# added by GJFB in 2020-08-18 - uses metadata2List and metadataList
}
# SAVE
set saveMetadata 1
SaveMetadata
}
# UpdateRepository2 - end
# ----------------------------------------------------------------------
# UpdateRepository
# documentType value is empty or default or directory
# empty means to deposit nothing in the updated repository
# default means to deposit the document from the default repository
# directory means to deposit a folder document named documentPath
# targetFileOption value is disable or enable
# option value is "copy" or "preserve" or "delete" (see DDRoutine)
# unzip value is 0 or 1; 1 means to unzip the deposited document
# copyToSource value is 0 or 1; 1 means to deposit the document into the source (only)
# moveToSource value is 0 or 1 ; 0 means don't move, 1 move the doc content to source - added by GJFB in 2016-05-10 to preserve old doc content before updating it - set in Administrator page for customizing the conference submission forms (iconet.com.br/banon/2006/07.02.02.18)
# moveBackToDoc value is 0 or 1 ; 0 means don't move, 1 move the source content to doc - added by GJFB in 2021-05-27 to give access to previously hidden video (ex: id 8JMKD3MGPGW34M/44N7JSP)
# postSubmissionScriptRepList is a list of repositories containing scripts to process
# the submitted files
# $reference ==>
# {%0 Misc} {%@tertiarytype } {%A aa} {%I Deposited in the URLib collection.} {%X aa} {%T tt} {%@secondarykey INPE--/}
# reference is used for post-submission
# deleteDocContentBeforeUpdate value is 0 or 1; 1 means to delete the doc content before depositing the new document - 1 is default
# updateAgreement value is 0 or 1; 1 means to update the agreement folder
proc UpdateRepository {
rep {documentType {empty}} {documentPath {}}
{targetFileOption disable} {option copy} {unzip 0} {userName {}}
{postSubmissionScriptRepList {}} {reference {}} {deleteDocContentBeforeUpdate 1}
{copyToSource 0} {folderName {}} {updateAgreement 0} {moveToSource 0}
{moveBackToDoc 0}
} {
# runs with start and post
# puts >>>UpdateRepository
set argument ""
set argument "$argument -targetfile $targetFileOption"
set argument "$argument -documenttype $documentType"
set argument "$argument -repositorytype repository"
set argument "$argument -option $option"
set argument "$argument -reverse 0"
set argument "$argument -documentpath [list $documentPath]"
set argument "$argument -repositoryentry [list [list :: $rep]]"
set argument "$argument -unzip $unzip"
set argument "$argument -selectedfiles no"
set argument "$argument -username $userName"
set argument "$argument -postsubmissionscriptreplist [list $postSubmissionScriptRepList]"
set argument "$argument -reference [list $reference]"
set argument "$argument -deletedoccontentbeforeupdate $deleteDocContentBeforeUpdate"
set argument "$argument -copytosource $copyToSource"
set argument "$argument -foldername [list $folderName]"
set argument "$argument -updateagreement $updateAgreement" ;# added by GJFB in 2010-12-05
set argument "$argument -movetosource $moveToSource" ;# added by GJFB in 2016-05-10
set argument "$argument -movebacktodoc $moveBackToDoc" ;# added by GJFB in 2021-05-27
# set xxx 1-$argument
# Store xxx C:/tmp/aaa auto 0 a
set return [DDRoutine $argument]
# set xxx $return
# Store xxx C:/tmp/aaa auto 0 a
if {$return == 1} {return}
if {$return == 0} {return}
return $return
}
# UpdateRepository - end
# ----------------------------------------------------------------------
# GetFieldValue
# used by DisplayMultipleSearch
proc GetFieldValue {rep-i fieldName {level {#0}}} {
# runs with start and post
upvar $level metadataArray metadataArray
if [info exists metadataArray(${rep-i},$fieldName)] {
set fieldValue $metadataArray(${rep-i},$fieldName)
} else {
set fieldValue {}
}
return $fieldValue
}
# GetFieldValue - end
# ----------------------------------------------------------------------
# GetFieldValue2
# used to call GetFieldValue from MultipleSubmit
# used in Script (administrator page for unifying field values)
proc GetFieldValue2 {rep-i fieldName {level {#0}}} {
return [GetFieldValue ${rep-i} $fieldName $level]
}
# GetFieldValue2 - end
# ----------------------------------------------------------------------
# GetMetadata
# example:
# set metadata2List [GetMetadata $callingRep-0,metadatalastupdate]
# set metadata2List [GetMetadata $rep-*]
proc GetMetadata {index} {
# runs with post
global metadataArray
return [array get metadataArray $index]
}
# GetMetadata - end
# ----------------------------------------------------------------------
# RemoveMetadata
# Example:
# set metadata2List [concat $metadata2List [GetMetadata $metadataRep-*]]
# RemoveMetadata $metadata2List
# removeOnly value is 0 or 1
# 1 means only remove (no add follows remove) - used when a repository is deleted
# use of metadataList is made in UpdateCollection
if 0 {
# commented by GJFB in 2021-03-24
# not used anymore
proc RemoveMetadata {metadata2List {removeOnly 0} {metadataList {}}} {
# runs with post
global metadataArray
global searchRepository
global commonWords
global maximumNumberOfEntries ;# defined in LoadGlobalVariables
# puts -2-$metadata2List--
# puts --$metadataList--
# Update abstract accelerator - added by GJFB in 2010-12-10
# get the difference between metadata2List and metadataList
array set newMetadataArray $metadataList
array set oldMetadataArray $metadata2List
# puts --[array names oldMetadataArray]--
set flag 0
foreach name [array names oldMetadataArray] {
# Update metadataArray
# if [info exists metadataArray($name)] {unset metadataArray($name)} ;# commented by GJFB in 2020-08-14
if {[info exists metadataArray($name)] && ![info exists newMetadataArray($name)]} {unset metadataArray($name)} ;# added by GJFB in 2020-08-14 to avoid unnecessary unset
# Update metadataArray - end
# if [regexp {abstract|synopsis} $name] # ;# commented by GJFB in 2020-08-14
if [regexp {abstract|synopsis|title} $name] { ;# added by GJFB in 2020-08-14
if [info exists newMetadataArray($name)] {
set flag 1 ;# metadata2List can be simplified
# puts "old == $oldMetadataArray($name)"
# puts "new == $newMetadataArray($name)"
regsub -all {[\.,;:]\s|\s['’"]|['’"]\s} [regsub -all {\s} " $oldMetadataArray($name) " { }] { } oldMetadataArray($name) ;# added by GJFB in 2020-08-14 - 'fim' "a'b" do resumo. -> fim a'b do resumo
regsub -all {[\.,;:]\s|\s['’"]|['’"]\s} [regsub -all {\s} " $newMetadataArray($name) " { }] { } newMetadataArray($name) ;# added by GJFB in 2020-08-14 - 'fim' "a'b" do resumo. -> fim a'b do resumo
set oldMetadataArray($name) [ListNegatedImplication oldMetadataArray($name) newMetadataArray($name)]
# puts "old = $oldMetadataArray($name)"
}
}
}
if $flag {
# use a simplified metadata2List
set metadata2List [array get oldMetadataArray] ;# added by GJFB in 2010-12-10
}
# Update abstract accelerator - end
# puts -2-$metadata2List--
${searchRepository}::CreateRepArray $metadata2List $commonWords 1 $removeOnly $maximumNumberOfEntries
}
}
# RemoveMetadata - end
# ----------------------------------------------------------------------
# RemoveMetadata2
# version 2 - 2020-08-18
proc RemoveMetadata2 {metadata2List {removeOnly 0}} {
# runs with post
global metadataArray
global searchRepository
global commonWords
global maximumNumberOfEntries ;# defined in LoadGlobalVariables
array set oldMetadataArray $metadata2List
# Update metadataArray
foreach name [array names oldMetadataArray] {
if [info exists metadataArray($name)] {unset metadataArray($name)}
}
# Update metadataArray - end
# Update repArray
${searchRepository}::CreateRepArray $metadata2List $commonWords 1 $removeOnly $maximumNumberOfEntries
# Update repArray - end
}
# RemoveMetadata2 - end
# ----------------------------------------------------------------------
# AddMetadata
# example: AddMetadata $metadataList
# use of metadata2List is made in UpdateCollection
if 0 {
# commented by GJFB in 2021-03-24
# not used anymore
proc AddMetadata {metadataList {metadata2List {}}} {
# runs with post
global metadataArray
global searchRepository
global commonWords
# puts =2-$metadata2List--
# puts =-$metadataList--
# Update metadataArray
array set metadataArray $metadataList
# Update metadataArray - end
# Update abstract accelerator - added by GJFB in 2010-12-10
# get the difference between metadataList and metadata2List
if ![string equal {} $metadata2List] {
array set newMetadataArray $metadataList
array set oldMetadataArray $metadata2List
set flag 0
foreach name [array names newMetadataArray] {
# if [regexp {abstract|synopsis} $name] # ;# commented by GJFB in 2020-08-14
if [regexp {abstract|synopsis|title} $name] { ;# added by GJFB in 2020-08-14
if [info exists oldMetadataArray($name)] {
set flag 1 ;# metadataList can be simplified
regsub -all {[\.,;:]\s|\s['’"]|['’"]\s} [regsub -all {\s} " $oldMetadataArray($name) " { }] { } oldMetadataArray($name) ;# added by GJFB in 2020-08-14 - 'fim' "a'b" do resumo. -> fim a'b do resumo
regsub -all {[\.,;:]\s|\s['’"]|['’"]\s} [regsub -all {\s} " $newMetadataArray($name) " { }] { } newMetadataArray($name) ;# added by GJFB in 2020-08-14 - 'fim' "a'b" do resumo. -> fim a'b do resumo
set newMetadataArray($name) [ListNegatedImplication newMetadataArray($name) oldMetadataArray($name)]
}
}
}
if $flag {
# use a simplified metadataList
set metadataList [array get newMetadataArray] ;# added by GJFB in 2010-12-10
}
}
# Update abstract accelerator - end
# puts =-$metadataList--
${searchRepository}::CreateRepArray $metadataList $commonWords
}
}
# AddMetadata - end
# ----------------------------------------------------------------------
# AddMetadata2
# version 2 - 2020-08-18
proc AddMetadata2 {metadataList} {
# runs with post
global metadataArray
global searchRepository
global commonWords
# Update metadataArray
array set metadataArray $metadataList
# Update metadataArray - end
# Update repArray
${searchRepository}::CreateRepArray $metadataList $commonWords
# Update repArray - end
}
# AddMetadata2 - end
# ----------------------------------------------------------------------
# UpdateMetadata
# updates metadataArray
# Example:
# set metadata2List [concat $metadata2List [GetMetadata $metadataRep-*]]
# UpdateMetadata $metadata2List
# removeOnly value is 0 or 1
# 1 means only remove (no add follows remove) - used when a repository is deleted
# use of metadataList is made in UpdateCollection
proc UpdateMetadata {metadata2List metadataList {removeOnly 0}} {
# runs with post
global metadataArray
global searchRepository
global commonWords
global maximumNumberOfEntries ;# defined in LoadGlobalVariables
array set newMetadataArray $metadataList
array set oldMetadataArray $metadata2List
set oldMetadataNameList [array names oldMetadataArray]
set newMetadataNameList [array names newMetadataArray]
set intersectionMetadataNameList [ListIntersection oldMetadataNameList newMetadataNameList]
# strictly old metadata
set strictlyOldMetadataNameList [ListNegatedImplication oldMetadataNameList newMetadataNameList]
foreach name $strictlyOldMetadataNameList {
if [info exists metadataArray($name)] {unset metadataArray($name)} ;# remove metadata
}
# strictly new metadata
set strictlyNewMetadataNameList [ListNegatedImplication newMetadataNameList oldMetadataNameList]
array set metadataArray $metadataList ;# add and update metadata
# update repArray
# distinctMetadataNameList
set distinctMetadataNameList {}
foreach name $intersectionMetadataNameList {
if ![string equal $oldMetadataArray($name) $newMetadataArray($name)] {
lappend distinctMetadataNameList $name
}
}
# atualOldMetadataArray
# atualNewMetadataArray
foreach name $distinctMetadataNameList {
if [regexp {abstract|synopsis|title} $name] {
regsub -all {[\.,;:]\s|\s['’"]|['’"]\s} [regsub -all {\s} " $oldMetadataArray($name) " { }] { } simplifiedOldMetadata ;# 'fim' "a'b" do resumo. -> fim a'b do resumo
regsub -all {[\.,;:]\s|\s['’"]|['’"]\s} [regsub -all {\s} " $newMetadataArray($name) " { }] { } simplifiedNewMetadata ;# 'fim' "a'b" do resumo. -> fim a'b do resumo
set simplifiedOldMetadata [lsort -unique $simplifiedOldMetadata]
set simplifiedNewMetadata [lsort -unique $simplifiedNewMetadata]
set atualOldMetadata [ListNegatedImplication simplifiedOldMetadata simplifiedNewMetadata]
if [llength $atualOldMetadata] {set atualOldMetadataArray($name) $atualOldMetadata}
set atualNewMetadata [ListNegatedImplication simplifiedNewMetadata simplifiedOldMetadata]
if [llength $atualNewMetadata] {set atualNewMetadataArray($name) $atualNewMetadata}
} else {
# other fields - added by GJFB in 2021-01-22
set atualOldMetadataArray($name) $oldMetadataArray($name)
set atualNewMetadataArray($name) $newMetadataArray($name)
}
}
# Compute the simplifiedMetadata2List containing just the necessary metadata to be removed in repArray
foreach name $strictlyOldMetadataNameList {
set atualOldMetadataArray($name) $oldMetadataArray($name)
}
if [info exists atualOldMetadataArray] {
# use a simplified metadata2List
set simplifiedMetadata2List [array get atualOldMetadataArray]
} else {
set simplifiedMetadata2List $metadata2List
}
${searchRepository}::CreateRepArray $simplifiedMetadata2List $commonWords 1 $removeOnly $maximumNumberOfEntries
# Compute the simplifiedMetadata2List containing just the necessary metadata to be removed in repArray - end
# Compute the simplifiedMetadataList containing just the necessary metadata to be added in repArray
foreach name $strictlyNewMetadataNameList {
set atualNewMetadataArray($name) $newMetadataArray($name)
}
if [info exists atualNewMetadataArray] {
# use a simplified metadataList
set simplifiedMetadataList [array get atualNewMetadataArray]
} else {
set simplifiedMetadataList $metadataList
}
# puts --$simplifiedMetadataList--
${searchRepository}::CreateRepArray $simplifiedMetadataList $commonWords
}
# UpdateMetadata - end
# ----------------------------------------------------------------------
# CreateExtraFields
## creates fields which are not part of EndNote, i.e., targetfile, lastupdate,
# creates fields which are part of the service directory, i.e., targetfile, lastupdate,
# metadatalastupdate, contenttype, hostcollection, site, size, numberoffiles,
# language, username, agreement
# used in UpdateCollection, LoadBiblioDB, StartService, UpdateMetadataBase and GetClipboard only
## not used in remote submission
# repositoryProperties -> metadataList
# or referenceTable -> metadataList (childrepositories and parentrepositories cases)
# or service -> metadataList (visibility, identifier, transferableflag and citingitemlist cases)
# or agreement -> metadataList
# site is the server address (e.g., banon-pc2 19050)
proc CreateExtraFields {metadataRep site} {
# runs with post
global errorInfo
global environmentArray
set error 1 ;# needed to know if an error has actually occurred within the catch (because catch returns 1 when an error was catch before by another catch, e.g. by catch {puts $sock $query} in PutQuery)
set errorInfo {} ;# needed in order to get the correct return value when no error occurs
if [catch {
global repositoryProperties
global homePath
# puts [CallTrace]
set repName [ReturnRepositoryName $metadataRep]
set metadataList {}
# Add the targetfile field
if [info exists repositoryProperties($repName,targetfile)] {
set targetFile $repositoryProperties($repName,targetfile)
# puts $targetFile
set metadataList [concat $metadataList [list $metadataRep-0,targetfile $targetFile]]
}
# Add the targetfile field - end
# Add the last update fields
if [info exists repositoryProperties($metadataRep,history)] {
# set versionStamp [lindex $repositoryProperties($metadataRep,history) end]
set versionStamp [GetVersionStamp $metadataRep]
set metadataList [concat $metadataList [list $metadataRep-0,metadatalastupdate $versionStamp]]
}
if [info exists repositoryProperties($repName,history)] {
# set versionStamp [lindex $repositoryProperties($repName,history) end]
set versionStamp [GetVersionStamp $repName]
set metadataList [concat $metadataList [list $metadataRep-0,lastupdate $versionStamp]]
# set xxx [CallTrace]
# Store xxx C:/tmp/aaa auto 0 a
## Tcl Call Trace
## 5: CreateExtraFields iconet.com.br/banon/2000/12.30.22.40.05 banon-pc.dpi.inpe.br:1905
## 4: UpdateMetadataBase iconet.com.br/banon/2000/12.30.22.40.05 metadataList metadata2List banon-pc.dpi.inpe.br:1905 update
## 3: CheckMetadataConsistency iconet.com.br/banon/2000/12.30.22.40.05-0 10
## 2: GetMetadataRepositories 0 {repository, iconet.com.br/banon/2000/12.30.22.40} no no 1 metadatalastupdate
## 1: ServeLocalCollection sock22 150.163.8.245
## Tcl Call Trace - end
# set xxx [list versionStamp = $versionStamp]
# Store xxx C:/tmp/aaa auto 0 a
}
# Add the last update fields - end
# Add the contenttype field
if [info exists repositoryProperties($repName,type)] {
set contentType $repositoryProperties($repName,type)
set metadataList [concat $metadataList [list $metadataRep-0,contenttype $contentType]]
}
# Add the contenttype field - end
# Add the copyright field
if [info exists repositoryProperties($repName,copyright)] {
set copyright $repositoryProperties($repName,copyright)
set metadataList [concat $metadataList [list $metadataRep-0,copyright $copyright]]
}
# Add the copyright field - end
# Add the hostcollection field
if [info exists repositoryProperties($repName,hostcollection)] {
# if [GetDocumentState $repName] # ;# commented by GJFB in 2015-11-16 - metadataList should be identical to repositoryProperties to avoid missinterpretation
## the document is the original
set hostCollection $repositoryProperties($repName,hostcollection)
set hostCollection [lrange $hostCollection 0 end] ;# added by GJFB in 2012-05-03 - turn hostCollection a list without new lines - useful for old data format
set metadataList [concat $metadataList [list $metadataRep-0,hostcollection $hostCollection]]
# #
}
# Add the hostcollection field - end
# Add the site field
set metadataList [concat $metadataList [list $metadataRep-0,site $site]]
# Add the site field - end
# Add the size field
if [info exists repositoryProperties($repName,size)] {
set size $repositoryProperties($repName,size)
set metadataList [concat $metadataList [list $metadataRep-0,size $size]]
}
# Add the size field - end
# Add the numberoffiles field
if [info exists repositoryProperties($repName,numberoffiles)] {
set numberOfFiles $repositoryProperties($repName,numberoffiles)
set metadataList [concat $metadataList [list $metadataRep-0,numberoffiles $numberOfFiles]]
}
# Add the numberoffiles field - end
# Add the language field
if [info exists repositoryProperties($repName,language)] {
set language $repositoryProperties($repName,language)
regexp {\[(.*)\]} $language m language ;# English {[en]} -> en
set metadataList [concat $metadataList [list $metadataRep-0,language $language]]
}
# Add the language field - end
# Add the textlanguage field
# added by GJFB in 2013-02-11 to search for the proper metadata repository based on its language and display the corresponding entry in the proper language
# useful for multiple language document to display resume or archival unit document in the proper language
if [info exists repositoryProperties($metadataRep,language)] {
set language $repositoryProperties($metadataRep,language)
regexp {\[(.*)\]} $language m language ;# English {[en]} -> en
set metadataList [concat $metadataList [list $metadataRep-0,textlanguage $language]]
}
# Add the textlanguage field - end
# Add username
if [info exists repositoryProperties($repName,username)] {
set userName $repositoryProperties($repName,username)
set metadataList [concat $metadataList [list $metadataRep-0,username $userName]]
}
# Add username - end
# Add authenticatedusers/readergroup
if [info exists repositoryProperties($repName,authenticatedusers)] {
set readerGroup $repositoryProperties($repName,authenticatedusers)
set metadataList [concat $metadataList [list $metadataRep-0,readergroup $readerGroup]]
}
# Add authenticatedusers/readergroup - end
# Add childrepositories field
set childRepositories [GetCitingRepositoryList $repName]
# Drop the metadataRep from the childRepositories
set i [lsearch -exact $childRepositories $metadataRep]
set childRepositories [lreplace $childRepositories $i $i]
# Drop the metadataRep from the childRepositories - end
if ![string equal {} $childRepositories] {
set metadataList [concat $metadataList [list $metadataRep-0,childrepositories $childRepositories]]
}
# Add childrepositories field - end
# Add parentrepositories field
set parentRepositories [GetCitedRepositoryList $repName]
if ![string equal {} $parentRepositories] {
set metadataList [concat $metadataList [list $metadataRep-0,parentrepositories $parentRepositories]]
}
# Add parentrepositories field - end
# Add readpermission field
if 0 {
# new code below
if [info exists repositoryProperties($repName,docpermission)] {
set docPermission $repositoryProperties($repName,docpermission)
# puts 1-$docPermission
regsub -all "\n" $docPermission { and } readPermission
set metadataList [concat $metadataList [list $metadataRep-0,readpermission $readPermission]]
}
}
# administratorUserName
regsub {@.*$} $environmentArray(spMailEntry) {} administratorUserName
# ipAddress
set ipAddress $environmentArray(ipAddress)
# compute default access
foreach {defaultAuthenticationFlag spDocAccessPermission spDownloadAccessPermission directivesForCGI} [ComputeDefaultAccess $ipAddress 1] {break}
# compute access
foreach {authDirectives docPermission downloadPermission} [ComputeAccess $repName $administratorUserName $defaultAuthenticationFlag $spDocAccessPermission $spDownloadAccessPermission $ipAddress 1] {break}
# puts 2-$docPermission
if ![string equal {} $docPermission] {
# set docPermission2 [string trim $docPermission \n] ;# added by GJFB in 2011-04-10
set docPermission2 [string trim $docPermission] ;# added by GJFB in 2015-04-19 - tab must be trimmed as well (otherwise, Permission and Remote Permission in Dialog doesn't work properly)
regsub -all "\n" $docPermission2 { and } readPermission
set metadataList [concat $metadataList [list $metadataRep-0,readpermission $readPermission]]
}
# Add readpermission field - end
# puts [CallTrace]
# Add visibility field
if [file exists $homePath/col/$repName/service/visibility] {
LoadService $repName visibility visibility 1 1
set metadataList [concat $metadataList [list $metadataRep-0,visibility [expr $visibility?{hidden}:{shown}]]]
}
# Add visibility field - end
# Add identifier field
if [file exists $homePath/col/$repName/service/identifier] {
LoadService $repName identifier identifier 1 1
set metadataList [concat $metadataList [list $metadataRep-0,identifier $identifier]]
}
# Add identifier field - end
# Add transferableflag field
if [file exists $homePath/col/$repName/service/transferableFlag] {
LoadService $repName transferableFlag transferableFlag 1 1
set metadataList [concat $metadataList [list $metadataRep-0,transferableflag $transferableFlag]]
}
# Add transferableflag field - end
# Add agreement field
set dir $homePath/col/$repName/agreement
if [file isdirectory $dir] {
set fileList {}
DirectoryContent fileList $dir $dir
set metadataList [concat $metadataList [list $metadataRep-0,agreement $fileList]]
}
# Add agreement field - end
# Add the citingitemlist field
# added by GJFB in 2024-01-21 - citingItemList is used by robust hyperlinks
if [file exists $homePath/col/$repName/service/citingItemList] {
source $homePath/col/$repName/service/citingItemList ;# citingArray
# Reduce to the 3 most frequent citing
# same code in UpdateCitingItemList
set citingList {}
foreach {repository frequency} [array get citingArray] {
lappend citingList [list $repository $frequency]
}
set value [lrange [lsort -integer -decreasing -index 1 $citingList] 0 2]
# Reduce to the 3 most frequent citing - end
set metadataList [concat $metadataList [list $metadataRep-0,citingitemlist $value]]
}
# Add the citingitemlist field - end
set error 0 ;# no error has occurred
return $metadataList
} m] {
if !$error {return $m}
lappend message "CreateExtraFields ([clock format [clock seconds]]):"
lappend message [CallTrace]
set log [join $message \n]
puts $log
Store log $homePath/@errorLog auto 0 a
error $m $errorInfo
}
}
# CreateExtraFields - end
# ----------------------------------------------------------------------
# UpdateSiteList
# Include/exclude Archive
# Updates the file @siteList.txt in the local bibliographic mirror repository.
# used only by InformURLibSystem
# siteRepIp is the list consisting of eight elements:
# archiveaddress the archive internet address,
# archiveserviceibi the archive local collection index ibi,
# archiveip the archive ip address,
# archiveprotocol the archive protocol,
# archiveplatformversion the archive URLibService repository last update,
# archiveadmemailaddress the archive administrator e-mail address
# agencyResolverAddress
# staticIPFlag
# called by Script in 'Resolver service for IBI generation and archive inclusion/exclusion' in col/urlib.net/www/2014/03.22.01.53/doc/cgi/script.tcl
# Examples:
# banon-pc.dpi.inpe.br:1906 dpi.inpe.br/banon/1999/09.07.13.24 150.163.8.245
# {mtc-m16d.sid.inpe.br 806} sid.inpe.br/mtc-m19@80/2009/08.21.17.02 150.163.34.248 USP 2020:03.22.18.45.55 bibdigital@inpe.br licuri.ibict.br 1
# {vaio 19050} dpi.inpe.br/banon/1999/01.09.22.14 192.168.0.102 USP 2020:05.24.17.29.52 gerald.banon@gmail.com 0 0
# {gjfb0520.sid.inpe.br 806} dpi.inpe.br/banon/2001/02.23.19.23 150.163.34.249 USP 2020:05.16.03.00.18 banon@dpi.inpe.br {} 1
# localCollectionPassword is the local collection password stored in service of loCoInRep
# it used to allow local collection with dynamic IP, updating @siteList.txt
## update of localCollectionPasswordArray.tcl requires executing unpost/post
# unpostFlag value is 0 or 1; 1 means that the remote local collection is beeing unposted
# @siteList.txt doesn't contain the reference to the current (i.e., local) site
# new version by GJFB in 2010-08-03 for security reason (to control access from dynamic IP)
proc UpdateSiteList {siteRepIp {localCollectionPassword {}} {unpostFlag 0}} {
# runs with post
global loBiMiRep
global loCoInRep
global col
# global localCollectionIndexDBRepository ;# commented by GJFB in 2010-08-04
# global localCollectionPasswordArray ;# added by GJFB in 2010-08-03 - commented by GJFB in 2020-05-23
# return 1 ;# for testing communication
if 0 {
# old code
if {![info exists localCollectionPasswordArray] && \
([file exists $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl] || \
[file exists $col/$loBiMiRep/auxdoc/localCollectionPasswordArrayBackup.tcl])} {
SourceWithBackup $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl localCollectionPasswordArray ;# set localCollectionPasswordArray
# localCollectionPasswordArray: loCoInRep |-> localCollectionPassword
# example: set localCollectionPasswordArray(dpi.inpe.br/banon/1999/01.09.22.14) 896322016416
# localCollectionPasswordArray must contain the local collection passwords of all the created local collections
}
} else {
if 0 {
# commented by GJFB in 2020-05-23
# new code by GJFB in 2014-11-03 - for security reason localCollectionPasswordArray must be updated manually
if [file exists $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl] {
set mTime [file mtime $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl]
} else {
set mTime 0
}
if [file exists $col/$loBiMiRep/auxdoc/sourceTime] {
Load $col/$loBiMiRep/auxdoc/sourceTime sourceTime
} else {
set sourceTime 0
}
# $mTime > $sourceTime means that localCollectionPasswordArray.tcl has been updated manually and should be sourced
# localCollectionPasswordArray
if {(![info exists localCollectionPasswordArray] || $mTime > $sourceTime) && \
([file exists $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl] || \
[file exists $col/$loBiMiRep/auxdoc/localCollectionPasswordArrayBackup.tcl])} {
SourceWithBackup $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl localCollectionPasswordArray ;# source the most recent file - set localCollectionPasswordArray
set sourceTime [clock seconds]
Store sourceTime $col/$loBiMiRep/auxdoc/sourceTime
# localCollectionPasswordArray: loCoInRep |-> localCollectionPassword
# example: set localCollectionPasswordArray(dpi.inpe.br/banon/1999/01.09.22.14) 896322016416
# localCollectionPasswordArray must contain the local collection passwords of all the created local collections
}
} else {
# added by GJFB in 2020-05-23 - simplifying
SourceWithBackup $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl localCollectionPasswordArray 1 ;# source the most recent file - set localCollectionPasswordArray
}
}
# site index (of the remote collection)
## foreach {site index ip} $siteRepIp {break}
## ip not used
foreach {site index} $siteRepIp {break}
if 0 {
# old scheme
if ![info exists localCollectionPasswordArray($index)] {return}
if ![string equal $localCollectionPassword $localCollectionPasswordArray($index)] {return}
} else {
# communication scheme step 5
if ![info exists localCollectionPasswordArray($index)] {return 2} ;# do nothing - Archive not yet registered - added by GJFB in 2014-11-04 for security reason
if ![string equal $localCollectionPassword $localCollectionPasswordArray($index)] {return 3} ;# do nothing - unfair request - wrong localCollectionPassword - added by GJFB in 2014-11-04 for security reason
}
# siteWithIP (of the remote collection)
set serverAddress [ReturnCommunicationAddress $site] ;# server address of the remote collection
# foreach {serverName urlibPort} $serverAddress {break}
# set siteWithIP [list $ip $urlibPort]
## Inclusion/exclusion confirmation
if !$unpostFlag { ;# if added by GJFB in 2018-05-25
# Inclusion confirmation
## security issue
if 0 {
# using USP (URLibService protocol)
# communication scheme step 3
set command [list list ReturnConfirmation]
# MULTIPLE SUBMIT
# set siteRepIpConfirmation [MultipleExecute [list $siteWithIP] $command] ;# commented by GJFB in 2010-12-08 - banon-pc3 returns to urlib.net (not ismm.dpi.inpe.br) when using ip 187.106.147.7 (provided by net)
# puts --$serverAddress-- ;# only port 1905 is allowed from dpi.inpe.br
# set siteRepIpConfirmation [MultipleExecute [list $serverAddress] $command] ;# added by GJFB in 2010-12-08 - banon-pc3 doesn't return when using an empty domain name - this is the correct behavior
set confirmation [MultipleExecute [list $serverAddress] $command] ;# added by GJFB in 2010-12-08 - banon-pc3 doesn't return when using an empty domain name - this is the correct behavior
} else {
# using HTTP
package require http
# servicesubject=inclusionConfirmationRequest
# communication scheme step 3
set queryString servicesubject=inclusionConfirmationRequest
set site2 [ReturnHTTPHost $site]
## J8LNKB5R7W/3FTRH3S == Archive service for IBI resolution
# http://gjfb0520.sid.inpe.br/dpi.inpe.br/banon/2001/02.23.19.23?servicesubject=inclusionConfirmationRequest
# http://licuri.ibict.br/urlib.net/www/2017/10.16.01.16?servicesubject=inclusionConfirmationRequest
# => confirmation yes
# GETURL
# if [catch {http::geturl [ConvertURLToHexadecimal http://$site2/J8LNKB5R7W/3FTRH3S?$queryString]} token] #
if [catch {http::geturl [ConvertURLToHexadecimal http://$site2/$index?$queryString 1]} token] {
# puts --$token-- ;# error message - --couldn't open socket: connection refused--
# set siteRepIpConfirmation {} ;# no response
set confirmation {} ;# no response
} else {
# geturl returned
if [string equal {404} [::http::ncode $token]] {
# not found
# puts {not found}
# set siteRepIpConfirmation {} ;# no response
set confirmation {} ;# no response
} else {
# puts OK
# set siteRepIpConfirmation [string trimright [http::data $token]]
set confirmation [string trimright [http::data $token]]
}
http::cleanup $token
}
}
# puts --$confirmation--
# if [string equal {} $siteRepIpConfirmation] #
if [string equal {} $confirmation] {
# no response
# probably a local collection using dynamic IP - use the local collection password to confirm
# local collection using dynamic IP cannot be registred for security reason
set staticIPFlag 0 ;# added by GJFB in 2010-08-14
# use as siteRepIp the proper argument of the proc
} else {
# confirmation received
set staticIPFlag 1 ;# added by GJFB in 2010-08-14
if [string equal $index $loCoInRep] {
# remote == current - don't add
return $staticIPFlag ;# return 1 - if left empty, one cannot create a new repository
}
if 0 {
# commented by GJFB in 2014-11-03
# for security reason localCollectionPasswordArray must be updated manually
# it is updated manually only in urlib.net at installation of a new collection
if {![info exists localCollectionPasswordArray($index)] || \
[string equal {} $localCollectionPasswordArray($index)]} {
# new local collection using static IP - register the localCollectionPassword
# registry is important because a local collection may become using dynamic IP in the future
set localCollectionPasswordArray($index) $localCollectionPassword
StoreArrayWithBackup localCollectionPasswordArray $col/$loBiMiRep/auxdoc/localCollectionPasswordArray.tcl w list
}
}
}
# Inclusion confirmation - end
} else {
set staticIPFlag {} ;# added by GJFB in 2018-05-25 - force staticIPFlag to empty (used in MultipleSubmit)
}
# siteList
LoadWithBackup $col/$loBiMiRep/doc/@siteList.txt fileContent
set fileContent [string trim $fileContent " \t\n"] ;# drop leading and trailing blank lines
regsub -all "\n+" $fileContent "\n" fileContent
set siteList [split $fileContent \n]
# if $unpostFlag {set staticIPFlag {}} ;# added by GJFB in 2010-09-20 - the collection is being unposted - force staticIPFlag to empty (used in MultipleSubmit) - commented by GJFB in 2018-05-25 (now above)
set flag 1 ;# siteList must be updated to include a new local collection
set siteList2 {}
foreach siteRepIp2 $siteList {
# index2
set index2 [lindex $siteRepIp2 1] ;# remote loCoInRep in @siteList.txt of the resolver
if [string equal $index2 $index] {
# update
set agencyResolverAddress2 [lindex $siteRepIp2 6] ;# remote agencyResolverAddress in @siteList.txt of the resolver - added by GJFB in 2017-02-20 - part of the agency structure code
set siteRepIp [lreplace $siteRepIp 6 6 $agencyResolverAddress2] ;# maintain the agencyResolverAddress value contained in @siteList.txt - added by GJFB in 2017-02-20 - part of the agency structure code
lappend siteList2 [concat $siteRepIp $staticIPFlag] ;# added by GJFB in 2010-08-14
set flag 0
} else {
# let unchange
lappend siteList2 $siteRepIp2
}
}
if $flag {
# add
# if $unpostFlag #
if 0 {
# the index should be previously registered - abnormal state
# added by GJFB in 2013-06-29 in order to avoid adding a new entry at unpost - sometimes at unpost the URLib server is in an abnormal state (in this case it has been observed that siteRepIpConfirmation above contains outputs of GetMetadataRepositories before the expected value)
StoreLog alert UpdateSiteList "unexpected value for siteRepIpConfirmation: $siteRepIpConfirmation"
} else {
# the index was not previously registered
lappend siteList2 [concat $siteRepIp $staticIPFlag] ;# added by GJFB in 2010-08-14
set agencyResolverAddress2 [lindex $siteRepIp 6] ;# the agencyResolverAddress value defined at installation of the remote Archive - added by GJFB in 2017-02-20 - part of the agency structure code
}
}
set fileContent2 [join $siteList2 \n]
# SAVE
StoreWithBackup fileContent2 $col/$loBiMiRep/doc/@siteList.txt
# return $staticIPFlag ;# added by GJFB in 2010-08-23 - commented by GJFB in 2017-02-20
# puts [list $staticIPFlag $agencyResolverAddress2]
# return [list $staticIPFlag $agencyResolverAddress2] ;# added by GJFB in 2017-02-20 - part of the agency structure code - commented by GJFB in 2022-06-06
return [list [list $staticIPFlag $agencyResolverAddress2]] ;# added by GJFB in 2022-06-06 - list is required because UpdateSiteList is remotely called using MultipleExecute (see resolver service for archive inclusion and exclusion - id J8LNKB5R7W/3FUQHC5)
}
## set loCoInRep dpi.inpe.br/banon/1999/01.09.22.14
# set loBiMiRep dpi.inpe.br/banon/1999/06.19.17.00
# set addr 200.210.103.243
# set col ../../../../..
# source cgi/mirrorfind-.tcl
# source utilities1.tcl
## source utilities2.tcl
# UpdateSiteList [list ntserver.iconet.com.br:1905 iconet.com.br/banon/2000/10.18.19.50 200.210.103.243 {2000:03.25.23.09.12 dpi.inpe.br/banon/1999/01.09.22.14} banon@iconet.com.br]
# UpdateSiteList - end
# ----------------------------------------------------------------------
# GetSiteList
# used in change.tcl
proc GetSiteList {input} {
global loBiMiRep
global col
if {[Compress $input] == "les.livres.sont.nos.amis"} {
Load $col/$loBiMiRep/doc/@siteList.txt fileContent
set fileContent [string trim $fileContent " \n"]
regsub -all "\n+" $fileContent "\n" fileContent
set siteList [split $fileContent \n]
} else {
set siteList {}
}
return $siteList
}
# GetSiteList - end
# ----------------------------------------------------------------------
# TestExecute
proc TestExecute {x} {
# global TestExecute
# after 10000 {set TestExecute 1}
# vwait TestExecute
return $x
}
# TestExecute - end
# ----------------------------------------------------------------------
# GetSiteStamp
# used in InformURLibSystem and TransferCopyright only
proc GetSiteStamp {} {
global col
global URLibServiceRepository
global loCoInRep
global environmentArray
global serverAddress
# set serverAddress [GetServerAddress] ;# could be drop using global serverAddress
set ip $environmentArray(ipAddress)
Load $col/$URLibServiceRepository/service/history history
set lastUpdate [lindex [lindex $history end] 0] ;# just date
set administratorEMailAddress $environmentArray(spMailEntry)
set archiveProtocol USP ;# USP (URlibService Protocol) or HTTP (Hypertext Transfer Protocol)
LoadService $loCoInRep agencyResolverAddress agencyResolverAddress 1 1 ;# added by GJFB in 2017-02-20 - part of the agency structure code
# return [list $serverAddress $loCoInRep $ip $archiveProtocol $lastUpdate $administratorEMailAddress] ;# commented by GJFB in 2017-02-20
return [list $serverAddress $loCoInRep $ip $archiveProtocol $lastUpdate $administratorEMailAddress $agencyResolverAddress] ;# added by GJFB in 2017-02-20 - part of the agency structure code
}
# GetSiteStamp
# ----------------------------------------------------------------------
# ReturnConfirmation
# used in UpdateSiteList and Script (urlib.net/www/2014/03.16.03.40) only
proc ReturnConfirmation {} {
return {confirmation yes} ;# could be anything but not empty
}
# ReturnConfirmation
# ----------------------------------------------------------------------
# InformURLibSystem
# InformURLibSystem is calling remotely UpdateSiteList through the Resolver service for IBI generation and archive inclusion/exclusion (id J8LNKB5R7W/3FUQHC5)
# Used in:
# post
# SPDialog (SPDialog.tcl)
# unpostFlag value is 0 or 1; 1 means that the local collection is beeing unposted
proc InformURLibSystem {{unpostFlag 0}} {
# runs with post
global homePath
global URLibServiceRepository
global serverAddress ;# set in LoadGlobalVariables
# global serverAddressWithIP ;# set in LoadGlobalVariables
global urlibServerAddress ;# set in LoadGlobalVariables
global loCoInRep
global loBiMiRep
# global staticIPFlag ;# set in this procedure - used in CreateEnvironmentArray (see StartServer.tcl) MakeRepository
global staticIPFlag ;# set in this procedure - used in MakeRepository (see DDDialog.tcl) and CreateFullEntry (see utilitiesMirror.tcl)
global environmentArray ;# changed temporarily in this procedure
global installInitialCollection ;# set in LoadGlobalVariables
global ipChangeFlag ;# set in post
global resolverIndexRepository ;# added by GJFB in 2017-12-21 to identify if the URLibService is running or not the urlib.net resolver
if [file exists $homePath/readOnlySite] {return}
# if {[string equal $serverAddress $urlibServerAddress] || [string equal www.$serverAddress $urlibServerAddress]} {return 1} - commented by GJFB in 2017-12-21
if [string equal $resolverIndexRepository $loCoInRep] {return 1} ;# added by GJFB in 2017-12-21
# about the file $homePath/@informURLibSystemFlag
# the file $homePath/@informURLibSystemFlag is created or removed manually only
# it is used when creating a copy of a local collection on a new host and the post command is run for testing on this new host
# this is useful when preparing a local collection migration between hosts
# the contain of $homePath/@informURLibSystemFlag is 0 or 1
# 1 must be used when the host has a static IP otherwise 0 must be used
# after migration the file $homePath/@informURLibSystemFlag must removed
if [file exists $homePath/@informURLibSystemFlag] { ;# added by GJFB in 2018-10-14 - to prepare a local collection migration between hosts
Load $homePath/@informURLibSystemFlag informURLibSystemFlag
set log "the local collection which index is $loCoInRep is a copy of an original local collection, its staticIPFlag was set to $informURLibSystemFlag (see $homePath/@informURLibSystemFlag file)"
puts [StoreLog {warning} {InformURLibSystem (1)} $log]
return $informURLibSystemFlag
}
# not the resolver urlib.net
if 0 {
# not used
# localCollectionPassword
if ![file exists $homePath/col/$URLibServiceRepository/auxdoc/localCollectionPassword] {
# localCollectionPassword file doesn't exist
regsub {0\.} [expr [SortRandomNumber]/double(233280)] {} localCollectionPassword
set data [Shift $loCoInRep $localCollectionPassword]
Store data $homePath/col/$URLibServiceRepository/auxdoc/localCollectionPassword binary 1
} else {
# localCollectionPassword file already exists
Load $homePath/col/$URLibServiceRepository/auxdoc/localCollectionPassword data binary
set data [UnShift $data]
set localCollectionPassword [lindex $data end]
}
}
if 0 {
# commented by GJFB in 2017-10-15 - now below - loCoInRep is not known at installation
if [LoadService $loCoInRep registrationPassword registrationPassword 1 1] {
# corrupted password
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] InformURLibSystem (1): $loCoInRep has a corrupted registration password\n"
puts $log
Store log $homePath/@errorLog auto 0 a
return
}
}
# puts "Registration key for $loCoInRep: $registrationPassword" ;# useful to register an Archive within the IBI resoltion system
set environmentArrayFlag [info exists environmentArray(sitesHavingReadPermission)]
if $environmentArrayFlag {
set sitesHavingReadPermission $environmentArray(sitesHavingReadPermission)
set environmentArray(sitesHavingReadPermission) {{Main Site}} ;# to allow confirmation of the output of GetSiteStamp by urlib.net (see UpdateSiteList) - otherwise UpdateSiteList might return 0 even for static IP (for example, when sitesHavingReadPermission is {{No Sites}}). In this case the domain name will be set to empty.
}
if $installInitialCollection {
set staticIPFlag 0
} else {
if [LoadService $loCoInRep registrationPassword registrationPassword 1 1] { ;# added by GJFB in 2017-10-15 - loCoInRep is not known at installation
# corrupted password
# set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] InformURLibSystem (1): $loCoInRep has a corrupted registration password\n"
# puts $log
# Store log $homePath/@errorLog auto 0 a
set log "$loCoInRep has a corrupted registration password"
puts [StoreLog {alert} {InformURLibSystem (2)} $log]
return
}
set siteStamp [GetSiteStamp]
# MULTIPLE SUBMIT
# UPDATESITELIST
# set staticIPFlag {} ;# reply of MultipleSubmit - must be global
if 0 {
# using USP (URLibService protocol)
set query [list list UpdateSiteList $siteStamp $registrationPassword $unpostFlag] ;# added by GJFB in 2010-09-20
# puts $query
if 0 {
set staticIPFlag {} ;# reply of MultipleSubmit - must be global
MultipleSubmit {} $query staticIPFlag 1 [list {www.urlib.net 800}] ;# used to update auxdoc/localCollectionPasswordArray.tcl and doc/@siteList.txt
} else {
# added by GJFB in 2012-12-19 to avoid using MultipleSubmit with empty pid
# set staticIPFlag [MultipleExecute [list {www.urlib.net 800}] $query 1] ;# scenario 1 - commented by GJFB in 2017-02-20
foreach {staticIPFlag agencyResolverAddress} [MultipleExecute [list {www.urlib.net 800}] $query] {break} ;# default scenario 0 - added by GJFB in 2017-02-20 - part of the agency structure code
# set staticIPFlag [MultipleExecute [list {gjfb.home 800}] $query 1]
# set staticIPFlag [Execute {gjfb 800} [list UpdateSiteList [GetSiteStamp] $registrationPassword $unpostFlag]]
}
} else {
# using HTTP
package require http ;# see online manual
# Convert URLibServive format to norm format
# communication scheme step 2
# set siteStampListForArray [ConvertSimpleListToListForArray {archiveaddress archiveserviceibi archiveip archiveprotocol archiveplatformversion archiveadmemailaddress} $siteStamp] ;# commented by GJFB in 2017-02-20
set siteStampListForArray [ConvertSimpleListToListForArray {archiveaddress archiveserviceibi archiveip archiveprotocol archiveplatformversion archiveadmemailaddress agencyresolveraddress} $siteStamp] ;# added by GJFB in 2017-02-20 - part of the agency structure code
if $unpostFlag {
set queryList servicesubject=exclusionRequest
} else {
set queryList servicesubject=inclusionRequest
}
foreach {name value} $siteStampListForArray {
lappend queryList $name=$value
}
foreach {name value} $siteStampListForArray {
if {$installInitialCollection && [string equal archiveserviceibi $name]} {
lappend queryList $name= ;# added by GJFB in 2016-04-28 - value of archiveserviceibi (loCoInRep) is empty at installation (loCoInRep is unknown before installation)
} else {
lappend queryList $name=$value
}
}
lappend queryList registrationkey=$registrationPassword ;# used in UpdateSiteList - should be encrypted
set queryString [join $queryList &]
# Convert URLibServive format to norm format - end
# set site2 www.urlib.net
set site2 [ReturnHTTPHost $urlibServerAddress] ;# www.urlib.net
# set site2 gjfb.home
# puts http://$site2/J8LNKB5R7W/3FUQHC5?$queryString
# =>
# http://www.urlib.net/J8LNKB5R7W/3FUQHC5?servicesubject=inclusionRequest&archiveaddress=gjfb.home+800&archiveserviceibi=dpi.inpe.br/banon/1999/01.09.22.14&archiveip=192.168.1.31&archiveprotocol=USP&archiveplatformversion=2014:10.04.01.25.28&archiveadmemailaddress=gerald.banon@gmail.com®istrationkey=896322016461
# http://www.urlib.net/J8LNKB5R7W/3FUQHC5?servicesubject=inclusionRequest&archiveaddress=gjfb.home+800&archiveserviceibi=dpi.inpe.br/banon/1999/01.09.22.14&archiveip=192.168.1.31&archiveprotocol=USP&archiveplatformversion=2014:10.04.01.25.28&archiveadmemailaddress=gerald.banon@gmail.com®istrationkey=896322016461&agencyresolveraddress=
# http://www.urlib.net/J8LNKB5R7W/3FUQHC5?servicesubject=exclusionRequest&archiveaddress=gjfb.home+800&archiveserviceibi=dpi.inpe.br/banon/1999/01.09.22.14&archiveip=192.168.1.31&archiveprotocol=USP&archiveplatformversion=2014:10.04.01.25.28&archiveadmemailaddress=gerald.banon@gmail.com®istrationkey=896322016461
# http://gjfb:1905/J8LNKB5R7W/3FUQHC5?servicesubject=exclusionRequest&archiveaddress=gjfb.home+800&archiveserviceibi=dpi.inpe.br/banon/1999/01.09.22.14&archiveip=192.168.1.31&archiveprotocol=USP&archiveplatformversion=2014:10.04.01.25.28&archiveadmemailaddress=gerald.banon@gmail.com®istrationkey=896322016461&agencyresolveraddress=
# J8LNKB5R7W/3FUQHC5 == Resolver service for IBI generation and archive inclusion/exclusion
# include Archive (2)
# exclude Archive (7)
# GETURL
if [catch {http::geturl [ConvertURLToHexadecimal http://$site2/J8LNKB5R7W/3FUQHC5?$queryString 1]} token] {
# puts --$token--
set staticIPFlag {} ;# no response
} else {
# geturl returned
if [string equal {404} [::http::ncode $token]] {
# not found
set log {404 - not found}
puts [StoreLog {error} {InformURLibSystem (3)} $log]
set staticIPFlag {} ;# no response
} else {
# puts OK
set resolverResponse [string trimright [http::data $token]]
# puts --$resolverResponse-- ;# >>> resolverResponse may content an error message
if [regexp {^<(.*)>$} $resolverResponse m errorMessage] {
set log $errorMessage
puts [StoreLog {error} {InformURLibSystem (4)} $log]
set staticIPFlag {}
} else {
set {responseArray(nothing to return)} {nothing to return}
if [catch {array set responseArray $resolverResponse} m] { ;# added by GJFB in 2016-04-02
# list element in quotes followed by ":" instead of space
# puts --$resolverResponse-- ;# >>> resolverResponse may content an error message without <>
## => --can't read "responseArray({})": no such element in array--
## => --can't read "staticIPFlag": no such variable-- ;# commented by GJFB in 2025-02-14 now solved in repos urlib.net/www/2014/03.22.01.53
# => --error writing "sock7": broken pipe--
set log $m\n--$resolverResponse--
puts [StoreLog {error} {InformURLibSystem (5)} $log] ;# added by GJFB in 2022-03-05
set staticIPFlag {} ;# no response - urlib.net need to be reposted, it returns "error writing "sock7": broken pipe"
} else {
ConditionalSet archiveStatus responseArray(status.archive) {}
ConditionalSet confirmationStatus responseArray(status.confirmation) {}
set staticIPFlag {}
if [string equal {included} $archiveStatus] {
set staticIPFlag [string equal {successful} $confirmationStatus] ;# 0 (dynamic IP or firewall problem), 1 (static IP) or empty (not registered, wrong key or unposted)
ConditionalSet agencyResolverAddress responseArray(agencyresolveraddress) {} ;# agencyresolveraddress is optional - added by GJFB in 2017-02-20 - part of the agency structure code
if [string equal {} $agencyResolverAddress] {
file delete $homePath/col/$loCoInRep/service/agencyResolverAddress
} else {
StoreService agencyResolverAddress $loCoInRep agencyResolverAddress 1 1 ;# added by GJFB in 2017-02-20 - part of the agency structure code - the value of agencyResolverAddress is stored in service/agencyResolverAddress but at the moment this (updated) value is not used by the URLibService
}
# Inform the agency resolver as well
if {![string equal {} $agencyResolverAddress] && ![string equal [ReturnHTTPHost $serverAddress] $agencyResolverAddress]} {
if ![catch {http::geturl [ConvertURLToHexadecimal http://$agencyResolverAddress/J8LNKB5R7W/3FUQHC5?$queryString 1]} token] { ;# added by GJFB in 2017-02-20 - part of the agency structure code
# geturl returned
http::cleanup $token
}
}
# Inform the agency resolver as well - end
}
}
}
}
# puts --[::http::data $token]--
# puts --[::http::code $token]--
# puts --[::http::status $token]--
# puts --[::http::error $token]--
http::cleanup $token
}
} ;# using HTTP - end
}
# puts --$staticIPFlag--
if $environmentArrayFlag {set environmentArray(sitesHavingReadPermission) $sitesHavingReadPermission} ;# restore the original permission (if any)
if {![string equal {} $staticIPFlag] || $ipChangeFlag || ![info exists environmentArray(staticIPFlag)]} { ;# added by GJFB in 2017-04-28 avoiding MakeRepository to crash when urlib.net is down (otherwise we would get a "Submission NOT completed..." message
set environmentArray(staticIPFlag) $staticIPFlag ;# added by GJFB in 2014-10-29 - used in MakeRepository only (when MakeRepository runs with start)
} else {
# staticIPFlag is empty and ipChangeFlag is 0 (no ip change) and environmentArray(staticIPFlag) exists
# leave environmentArray(staticIPFlag) as it is because urlib.net may be down when running post (in this case staticIPFlag is empty and MakeRepository crashes)
}
return $staticIPFlag ;# added by GJFB in 2010-08-23
}
# InformURLibSystem - end
# ----------------------------------------------------------------------
# GetAuthor
# comma value is {,} or {}
# {} is used in the BibINPE format
# example:
# with comma == {,}
# GetAuthor returns: Banon, G. J. F.,
# with comma == {}
# GetAuthor returns: Banon, G. J. F.
# nameFormat value is short, familynamefirst or familynamelast
# (used by CreateBriefTitleAuthorEntry)
proc GetAuthor {rep-i {level {#0}} {comma {,}} {nameFormat {short}}} {
global referRepository
global ${referRepository}::conversionTable
upvar $level metadataArray metadataArray
if {$level != "#0"} {set level [expr $level + 1]}
set type [ReturnType metadataArray ${rep-i} $level]
if [info exists metadataArray(${rep-i},$conversionTable($type,%A))] {
set authorList $metadataArray(${rep-i},$conversionTable($type,%A))
} else {
return
}
return [FormatAuthorName $authorList $comma $nameFormat]
}
# GetAuthor - end
# ----------------------------------------------------------------------
# CapitalizeLastName
# comma value is {,} or {}
# {} is used in the BibINPE format
# example:
# with comma == {,}
# CapitalizeLastName returns: BANON, Gerald Jean Francis,
# with comma == {}
# CapitalizeLastName returns: BANON, Gerald Jean Francis
proc CapitalizeLastName {authorList {comma {}}} {
set authorList2 {}
foreach author $authorList {
regsub {,$} $author {} author
if [regexp {(.*),(.*)} $author m lastName otherNames] {
lappend authorList2 "[string toupper $lastName], $otherNames$comma"
} else {
lappend authorList2 "[string toupper $author]$comma"
}
}
return $authorList2
}
# CapitalizeLastName - end
# ----------------------------------------------------------------------
# LoadServiceData
# Examples:
# LoadServiceData $rep contenttype type type
# LoadServiceData $rep lastupdate history history
# service -> repositoryProperties array
proc LoadServiceData {rep fieldName fileName indexName} {
# runs with post
global col
global repositoryProperties
if [file exists $col/$rep/service/$fileName] {
if [regexp {^username|^hostcollection|^mirrorsites|^docremotepermission|^downloadremotepermission} $fieldName] {
LoadService $rep $fileName fileContent 1 1
} else {
Load $col/$rep/service/$fileName fileContent
}
set fileContent [string trim $fileContent \n]
if {$fileContent == {}} {
if [info exists repositoryProperties($rep,$indexName)] {
unset repositoryProperties($rep,$indexName)
}
file delete $col/$rep/service/$fileName
} else {
# puts "$indexName = $fileContent"
set repositoryProperties($rep,$indexName) $fileContent
}
} else {
if [info exists repositoryProperties($rep,$indexName)] {
unset repositoryProperties($rep,$indexName)
}
}
}
# LoadServiceData - end
# ----------------------------------------------------------------------
# UpdateRepositoryProperties
# Update properties in repositoryProperties from the files in the
# service directory
# field value is all (default) or a field name (e.g., hostcollection)
# all means update all fields
# if rep doesn't exists the data are deleted
#
# field names examples:
# targetfile, lastupdate, contenttype, hostcollection,
# size, numberoffiles, copyright, docpermission,
# downloadpermission, language, mirrorsites,
# docremotepermission, downloadremotepermission,
# authenticatedusers, username
#
# service -> repositoriesProperties array (done in LoadServiceData)
proc UpdateRepositoryProperties {rep {field {all}}} {
# runs with post
global fieldNameArray ;# set in LoadGlobalVariables
if {$rep == {}} {return}
if {$field == "all"} {
foreach field [array names fieldNameArray] {
eval "LoadServiceData $rep $fieldNameArray($field)"
# LoadServiceData $rep $fieldNameArray($field)
}
} else {
eval "LoadServiceData $rep $fieldNameArray($field)"
# LoadServiceData $rep $fieldNameArray($field)
}
}
# UpdateRepositoryProperties - end
# ----------------------------------------------------------------------
# GetTargetFile
# used in ReturnTargetFileContent and Copyright (cgi/copyright.tcl)
proc GetTargetFile {rep} {
# runs with post
global repositoryProperties
if 0 {
# commmented by GJFB in 2023-03-07
set rep2 [string tolower $rep] ;# rep is case-insensitive
if [info exists repositoryProperties($rep2,targetfile)] {
set targetFile $repositoryProperties($rep2,targetfile)
} elseif [info exists repositoryProperties($rep,targetfile)] {
# dpi.inpe.br/Gemini and sid.inpe.br/MTC-m13 are exceptions
set targetFile $repositoryProperties($rep,targetfile)
} else {
set targetFile {}
}
} else {
# added by GJFB in 2023-03-07 - rep should be the repository name as it is in the file system, possibly with some capital letters, therefore the code above can be simplified
if [info exists repositoryProperties($rep,targetfile)] {
set targetFile $repositoryProperties($rep,targetfile)
} else {
set targetFile {}
}
}
return $targetFile
}
# GetTargetFile - end
# ----------------------------------------------------------------------
# GetEncodingName
proc GetEncodingName {} {
return [encoding system]
}
# GetEncodingName - end
# ----------------------------------------------------------------------
# GetAuthorHomePage
proc GetAuthorHomePage {rep} {
global repositoryProperties
if [info exists repositoryProperties($rep,authorhomepage)] {
set authorHomePage $repositoryProperties($rep,authorhomepage)
} else {
set authorHomePage {}
}
return $authorHomePage
}
# GetAuthorHomePage - end
# ----------------------------------------------------------------------
# GetCitedRepositoryList
# Return the list of cited repositories in the document
# contained in $rep
# flag value is 0, 1 or 2
# 0 means to return all
# 1 means to exclude the cited copyright repositories
# 2 means to return just the first (if any) mirror repository (used in CreatePage)
# extrated from the referenceTable array
# GetCitedRepositoryList is NOT RECURSIVE
# repository name must NOT contain comma (see regsub below)
proc GetCitedRepositoryList {rep {flag 0}} {
# runs with post
global referenceTable
set indexList [array names referenceTable $rep,*]
if $flag {
set citedRepositoryList {}
if {$flag == 1} {
# exclude the cited copyright repositories
foreach index $indexList {
regsub {.*,} $index {} citedRep
if {![TestContentType $citedRep {Copyright}] && \
![TestContentType $citedRep {Local Copyright}]} {
lappend citedRepositoryList $citedRep
}
}
}
if {$flag == 2} {
# return just the first mirror repository
foreach index $indexList {
regsub {.*,} $index {} citedRep
if [TestContentType $citedRep {Mirror}] {
set citedRepositoryList $citedRep
break
}
}
}
} else {
# return all
regsub -all { [^,]*,} " $indexList" { } citedRepositoryList
set citedRepositoryList [string trimleft $citedRepositoryList]
}
return $citedRepositoryList
}
# GetCitedRepositoryList - end
# ----------------------------------------------------------------------
# GetCitingRepositoryList
# Return the list of citing repositories in the document
# contained in $rep (including metadata repositories)
proc GetCitingRepositoryList {rep} {
# runs with post
global referenceTable
set indexList [array names referenceTable *,$rep]
set citingRepositoryList {}
foreach index $indexList {
regsub {,.*} $index {} citingRep
lappend citingRepositoryList $citingRep
}
return $citingRepositoryList
}
# GetCitingRepositoryList - end
# ----------------------------------------------------------------------
# GetCitingRepositoryList-
# Return the list of citing repositories in the document
# contained in $rep, excluding the metadata repositories
proc GetCitingRepositoryList- {rep entryWidget varName} {
# runs with start
set metadataRepList [FindMetadataRepList $rep $entryWidget $varName]
set list [Eval GetCitingRepositoryList $rep]
set citingRepositoryList {}
foreach citingRepository $list {
set break 0
foreach metadataRep $metadataRepList {
if {[string compare $citingRepository $metadataRep] == 0} {
set break 1
break
}
}
if !$break {lappend citingRepositoryList $citingRepository}
}
return $citingRepositoryList
}
# GetCitingRepositoryList- - end
# ----------------------------------------------------------------------
# FindPreferredLanguage
# finds the available translations of the firstLanguageRep
# returns the language in languageButton if this language is among the available translations of the firstLanguageRep
# otherwise it returns the preferred language (usually based on the browser language preference given in languagePreference) if this language is among the available translations of the firstLanguageRep
# otherwise it returns the language of the firstLanguageRep
# i.e., when languageButton is not empty and is among the available translations of the firstLanguageRep it has priority over the preferred language
# used in FindLanguage and FindLanguageForSubmissionForm (utilities1.tcl)
# fileName is the target file without the language prefix
# Example: filName is Index.html for the target files enIndex.html, pt-BRIndex.html, ...
# or FillingInstructions.tcl (previously, Submit.html) for the target files enFillingInstructions.tcl,
# pt-BRFillingInstructions.tcl, ...
# languageButton value is en, pt-BR ...
# languagePreference is for example, using env(HTTP_ACCEPT_LANGUAGE): pt-br,en;q=0.5
proc FindPreferredLanguage {firstLanguageRep fileName languagePreference languageButton} {
# runs with post
global referenceTable
global repositoryProperties
set languageRepList {}
# Find the language of the firstLanguageRep
# >>>>> xx$fileName MUST BE the target file of firstLanguageRep <<<<<
if [info exists repositoryProperties($firstLanguageRep,targetfile)] {
set targetFile $repositoryProperties($firstLanguageRep,targetfile)
if [regexp "(.*)$fileName" $targetFile m firstLanguage] {
set languageRepList [list $firstLanguage $firstLanguageRep]
} else {
if 0 {
# Migration 12/11/04
if {[string compare FillingInstructions.tcl $fileName] == 0} {
if [regexp "(.*)Submit\.html" $targetFile m firstLanguage] {
set languageRepList [list $firstLanguage $firstLanguageRep]
}
}
# Migration 12/11/04 - end
}
}
}
# Find the language of the firstLanguageRep - end
# Explore the child repositories of the firstLanguageRep
foreach index [array names referenceTable *,$firstLanguageRep] {
regsub {,.*} $index {} rep
if [info exists repositoryProperties($rep,targetfile)] {
set targetFile $repositoryProperties($rep,targetfile)
if [regexp "(.*)$fileName" $targetFile m language] {
if {[info exists firstLanguage] && [string compare $firstLanguage $language] == 0} {continue}
set languageRepList [concat $languageRepList [list $language $rep]]
} else {
if 0 {
# Migration 12/11/04
if {[string compare FillingInstructions.tcl $fileName] == 0} {
if [regexp "(.*)Submit\.html" $targetFile m language] {
if {[info exists firstLanguage] && [string compare $firstLanguage $language] == 0} {continue}
set languageRepList [concat $languageRepList [list $language $rep]]
}
}
# Migration 12/11/04 - end
}
}
}
}
# Explore the child repositories of the firstLanguageRep - end
if {$languageRepList == ""} {return [list {} {}]} ;# may cause problem (e.g., with sendMail.php)
# languageRepArray
array set languageRepArray $languageRepList
# puts [array names languageRepArray]
# => pt-BR en
set language [lindex $languageRepList 0] ;# first language
# puts 1-$language
# StoreLog {notice} {FindPreferredLanguage} 1-$language
# if {![string equal {} $languageButton] && [lsearch -exact [array names languageRepArray] $languageButton] != -1} #
# set language $languageButton
# new code added by GJFB in 2012-06-29 to convert pt into pt-BR
if {![string equal {} $languageButton] && [set i [lsearch -regexp [array names languageRepArray] ^$languageButton]] != -1} {
set language [lindex [array names languageRepArray] $i]
} elseif {$languagePreference != ""} {
foreach preferredLanguage [split $languagePreference ,] {
set preferredLanguage [lindex [split $preferredLanguage \;] 0] ;# pt-br
regexp {(..)(.*)} $preferredLanguage m a b
set preferredLanguage $a[string toupper $b] ;# pt-br -> pt-BR
if {[lsearch -exact [array names languageRepArray] $preferredLanguage] != -1} {
set language $preferredLanguage
break
}
}
}
# puts 2-$language
set languageRep $languageRepArray($language)
return [list $language $languageRep]
}
# FindPreferredLanguage - end
# ----------------------------------------------------------------------
# FindLanguageRepList
# Find the available translations of the firstLanguageRep
# Used in FindLanguage (utilities1.tcl)
# fileName is the target file without the language prefix
# Example: filName is Form.html for the target files enForm.html,
# pt-BRForm.html, ...
# not used
proc FindLanguageRepList {firstLanguageRep fileName} {
global referenceTable
global repositoryProperties
set languageRepList ""
if {[info exists repositoryProperties($firstLanguageRep,targetfile)] && \
[regexp "(.*)$fileName" \
$repositoryProperties($firstLanguageRep,targetfile) \
m language]} {
set languageRepList [list $language $firstLanguageRep]
}
foreach index [array names referenceTable *,$firstLanguageRep] {
regsub {,.*} $index {} rep
if {[info exists repositoryProperties($rep,targetfile)] && \
[regexp "(.*)$fileName" \
$repositoryProperties($rep,targetfile) \
m language]} {
set languageRepList [concat $languageRepList \
[list $language $rep]]
}
}
return $languageRepList
}
# FindLanguageRepList - end
# ----------------------------------------------------------------------
# CheckMetadataConsistency
# Check the metadata consistency with the file system
# (just for a short list of metadata - less than $maximumNumberOfEntries)
# used by StartService, FindMetadataRep and RemoveRepository
# rep-iListName is a list of metadata repositories
# simplyfied version - effective just for missing repositories
proc CheckMetadataConsistency {rep-iListName {maximumNumberOfEntries 1}} {
# runs with post
global col
global homePath
global metadataArray
global loCoInRep
# global serverAddress
global deletedRepositoryList
global deletedIdentifierList
upvar ${rep-iListName} rep-iList
# set xxx ${rep-iList}
# Store xxx C:/tmp/bbb.txt auto 0 a
# set xxx [CallTrace]
# puts $xxx
# Store xxx C:/tmp/bbb.txt auto 0 a
set update 0
if {[llength ${rep-iList}] <= "$maximumNumberOfEntries"} {
## site
## set site [GetServerAddress]
# set site $serverAddress
set list {}
set metadataList {} ;# for add
set metadata2List {} ;# for remove
set removeOnly 0
foreach rep-i ${rep-iList} {
# regsub -- {-[^-]*$} ${rep-i} {} metadataRep
regexp {(.*)-([^-]*)$} ${rep-i} m metadataRep i ;# i not used
if ![file isdirectory $col/$metadataRep] {
# the metadata repository has been deleted
# the deletedRecord argument is needed because insertionOn- may be already in use
# when CheckMetadataConsistency is called
# Waiting for the completion of other authentications
WaitQueue CheckMetadataConsistency deletedRecord
# Waiting for the completion of other authentications - end
set metadata2List [concat $metadata2List [GetMetadata $metadataRep-*]] ;# extract from the global array: metadataArray
# Transient deleted record
# if [info exists metadataArray(${rep-i},hostcollection)] #
if [ReturnState ${rep-i}] {
# just the repositories containing an original document are considered
if [file exists $col/$loCoInRep/doc/@deletedRecordList.tcl] {
source $col/$loCoInRep/doc/@deletedRecordList.tcl ;# set deletedRecordList - used with OAI-PMH only (see iconet.com.br/banon/2003/11.21.21.08)
} else {
set deletedRecordList {}
}
# metadataLastUpdate
set metadataLastUpdate [lindex [CreateVersionStamp [clock seconds]] 0]
if {[lsearch -exact $deletedRecordList $metadataRep-0] == -1} {
# not found
lappend deletedRecordList $metadataRep-0 $metadataLastUpdate
# STORE
StoreArray deletedRecordList $col/$loCoInRep/doc/@deletedRecordList.tcl w list listforarray 1
}
set storeFlag 0 ;# don't store
if [info exists metadataArray(${rep-i},repository)] {
set repository $metadataArray(${rep-i},repository)
if ![file isdirectory $col/$repository] {
if {[lsearch -exact $deletedRepositoryList $repository] == -1} {
# not found
lappend deletedRepositoryList $repository $metadataLastUpdate
set storeFlag 1 ;# store
}
}
}
if {[lsearch -exact $deletedRepositoryList $metadataRep] == -1} {
# not found
lappend deletedRepositoryList $metadataRep $metadataLastUpdate
set storeFlag 1 ;# store
}
# STORE
if $storeFlag {StoreArray deletedRepositoryList $col/$loCoInRep/doc/@deletedRepositoryList.tcl w list listforarray 1}
if [info exists metadataArray(${rep-i},identifier)] {
set identifier $metadataArray(${rep-i},identifier)
if {[lsearch -exact $deletedIdentifierList $identifier] == -1} {
# not found
lappend deletedIdentifierList $identifier $metadataLastUpdate
# STORE
StoreArray deletedIdentifierList $col/$loCoInRep/doc/@deletedIdentifierList.tcl w list listforarray 1
}
}
}
# Transient deleted record - end
set rep [ReturnRepositoryName $metadataRep]
UpdateVariables $rep ;# discard from repositoryProperties and referenceTable
UpdateVariables $metadataRep ;# discard from repositoryProperties and referenceTable
set update 1
LeaveQueue [pid] deletedRecord
} else {
# the metadata repository exists
lappend list ${rep-i}
}
}
if $update {
# Update metadata
# puts {updating...}
## RemoveMetadata $metadata2List 1 ;# commented by GJFB in 2021-03-24
# RemoveMetadata $metadata2List 1 ;# commented by GJFB in 2020-08-18
RemoveMetadata2 $metadata2List 1 ;# added by GJFB in 2020-08-18
# Update metadata - end
}
set rep-iList $list
} else {
# set list ${rep-iList}
}
# return [list $list $update]
return $update
}
# CheckMetadataConsistency - end
# ----------------------------------------------------------------------
# UpdateReferenceTable
# updates references
# service/reference is a fileName for a file containing the patterns
# (starting from doc) like xxx.tcl or *.html
# of files that may contain relative links to other repositories
# or a proper relative link
# example of service/reference file content:
# ../../../../../../col/dpi.inpe.br/banon/1999/10.31.20.32
# xxx.tcl
# *.html
# discard value is 0 or 1
# 1 means to discard any old references in rep (i.e, the parent repositories)
# 0 means to doesn't discard (used only when we know that there is no
# old reference in rep)
# if rep doesn't exists the data are deleted (discard must be 1)
# service -> referenceTable
proc UpdateReferenceTable {rep {discard 1}} {
# runs with post
global referenceTable
global homePath
global col
global pwd
global loCoInRep
# set xxx [CallTrace]
# Store xxx C:/tmp/aaa auto 0 a
# the references may be old and must be discarded
if $discard {DiscardRepository $rep referenceTable}
if ![file isdirectory $homePath/col/$rep] {return}
if 0 {
# not used anymore since 2009-07-16
# process copyright data
if [file exists $homePath/col/$rep/service/copyright] {
Load $homePath/col/$rep/service/copyright copyright
foreach repName $copyright {
set referenceTable($rep,$repName) 1
}
}
}
# process reference data
if [file exists $homePath/col/$rep/service/reference] {
set fileList {}
Load $homePath/col/$rep/service/reference reference
# set reference [string trim $reference \n]
foreach line [split $reference \n] {
if [regexp {^../} $line] {
# called repository in the reference file
# examples:
# ../../../../../../col/dpi.inpe.br/banon/1999/10.31.20.32
# ../../../../../../col/iconet.com.br/banon/2001/02.10.22.55 +
# + indicates that rep is a translation of the calledRep (here iconet.com.br/banon/2001/02.10.22.55)
if [regexp \
"../$col/col/(\[^/\]*/\[^/\]*/\[^/\]*/\[^/ \]*).*$" $line m calledRep] {
if {[llength $m] == 2} {
set value [lindex $m 1] ;# +
} else {
set value 1
}
set referenceTable($rep,$calledRep) $value
} else {
if [TestContentType $rep Metadata] {
# the link to the repository containing the document has been corrupted
# it should be recreated
# 1
file delete $homePath/col/$rep/service/reference
if [CreateReferenceFile $rep] {
lappend message "UpdateReferenceTable (1) ([clock format [clock seconds]]): reference file not recreated"
lappend message "%4 field in $homePath/col/$rep/doc/@metadata.refer has been probably damaged"
lappend message [CallTrace]
set log [join $message \n]
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
}
} else {
# the line contains a pattern to files to be searched
if [regexp {^ *\* *$} $reference] {
# * - get all the files below doc
set dir $homePath/col/$rep/doc
DirectoryContent fileList $dir $dir
} else {
if [TestContentType $rep Metadata] {
# the link to the repository containing the document has been corrupted
# it should be recreated
# 2
file delete $homePath/col/$rep/service/reference
if [CreateReferenceFile $rep] {
lappend message "UpdateReferenceTable (2) ([clock format [clock seconds]]): reference file not recreated"
lappend message "%4 field in $homePath/col/$rep/doc/@metadata.refer has been probably damaged"
lappend message [CallTrace]
set log [join $message \n]
puts $log
Store log $homePath/@errorLog auto 0 a
}
} else {
cd $homePath/col/$rep/doc
set fileList2 [glob -nocomplain -- $line]
cd $pwd
set fileList [concat $fileList $fileList2]
}
}
}
}
foreach file $fileList {
if [catch {open $col/$rep/doc/$file r} fileId] {
puts stderr $fileId
} else {
set fileContent [read $fileId]
foreach line [split $fileContent \n] {
if [regexp \
"../$col/col/(\[^/\]*/\[^/\]*/\[^/\]*/\[^/ >\]*)" $line m calledRep] {
set referenceTable($rep,$calledRep) 1
}
}
close $fileId
}
}
} else {
if [TestContentType $rep Metadata] {
# the link to the repository containing the document has been lost
# it should be recreated
# 3
if [CreateReferenceFile $rep] {
lappend message "UpdateReferenceTable (3) ([clock format [clock seconds]]): reference file not recreated"
lappend message "%4 field in $homePath/col/$rep/doc/@metadata.refer has been probably damaged"
lappend message [CallTrace]
set log [join $message \n]
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
}
if 0 {
if ![info exists loCoInRep] {return} ;# installation time
if [TestContentType $rep Metadata] {
# establishes a virtual link between loCoInRep and rep
set referenceTable($loCoInRep,$rep) 1
}
}
}
# UpdateReferenceTable - end
# ----------------------------------------------------------------------
# DiscardRepository
# varName examples: repositoryProperties, referenceTable, ...
proc DiscardRepository {rep varName} {
upvar #0 $varName var
set flag 0
foreach index [array names var $rep,*] {
unset var($index)
set flag 1
}
return $flag
}
# DiscardRepository - end
# ----------------------------------------------------------------------
# UpdateMetadataBase
# (used with CheckMetadataConsistency and PerformCheck)
# updates metadata from repositoryProperties, reference, service and @metadata.refer
# we assume that a UpdateRepositoryProperties for the METADATA repository was done before
# on output, flag value 1 means that the metadata base must be updated
# (used only in CheckMetadataConsistency)
# service -> repositoryProperties -> metadataList and metadata2List - (service -> repositoryProperties done in UpdateRepositoryProperties)
# site is the server address (e.g., banon-pc2 19050)
proc UpdateMetadataBase {metadataRep metadataListName metadata2ListName site flagName} {
# runs with post
global col
global metadataArray
global repositoryProperties
# global startApacheServer
upvar $metadataListName metadataList
upvar $metadata2ListName metadata2List
upvar $flagName flag
# puts [CallTrace]
# repName
set repName [ReturnRepositoryName $metadataRep]
UpdateRepositoryProperties $repName
UpdateReferenceTable $repName
if ![info exists repositoryProperties($repName,history)] {return}
# versionStamp for repName
# set history $repositoryProperties($repName,history)
# set repStamp [lindex $history end]
set repStamp [GetVersionStamp $repName] ;# uses repositoryProperties
if ![info exists repositoryProperties($metadataRep,history)] {return}
# versionStamp for metadataRep
# set history $repositoryProperties($metadataRep,history)
# set metadataRepStamp [lindex $history end]
set metadataRepStamp [GetVersionStamp $metadataRep] ;# uses repositoryProperties
if {![info exists metadataArray($metadataRep-0,lastupdate)] || \
![info exists metadataArray($metadataRep-0,metadatalastupdate)] || \
[GetLastUpdate $metadataRep-0] != "$repStamp" || \
$metadataArray($metadataRep-0,metadatalastupdate) != "$metadataRepStamp"} {
# Update metadata lists
Load $col/$metadataRep/doc/@metadata.refer fileContent
set metadataList [concat $metadataList [ConvertMultipleRefer2MetadataList 0 $fileContent $metadataRep]]
set metadataList [concat $metadataList [CreateExtraFields $metadataRep $site]]
set metadata2List [concat $metadata2List [GetMetadata $metadataRep-*]]
set flag 1
# Update metadata lists - end
}
}
# UpdateMetadataBase - end
# ----------------------------------------------------------------------
# FindCopyrightRepositories
# Finds the repositories containing the copyrights (in the first language)
# such repositories are:
# 1. the copyright repository of repName (defined in the file service/copyright) (if any)
# and the copyright repositories of PARENT repositories of repName (if any)
# 2. the local copyright repositories (if any)
# 3. the default copyright warning repository
# used in Copyright only
proc FindCopyrightRepositories {repName language} {
# runs with post
global referenceTable
global repositoryProperties
global copyrightWarningRepository ;# Default copyright warning for the URLib collection
# global loCoInRep
global homePath
# 1.
# puts 1.
# look for copyright repositories of repName and of its parents
set citedRepositoryList [CreateCitedRepositoryList $repName] ;# get the parent repositories recursively
# puts citedRepositoryList=--$citedRepositoryList--
lappend citedRepositoryList $repName ;# include repName
# set copyrightRepositories {}
foreach citedRepository $citedRepositoryList {
if [file exists $homePath/col/$citedRepository/service/copyright] {
Load $homePath/col/$citedRepository/service/copyright copyrightRep
# puts copyrightRep=--$copyrightRep--
# Find copyright repository in the appropriate language
set siteRep [FindSite2 $copyrightRep 1 $language] ;# find rep in the appropriate language
# puts siteRep=--$siteRep--
if {$siteRep == {}} {
# site not found
set appropriateCopyrightRep $copyrightRep
} else {
foreach {site appropriateCopyrightRep} $siteRep {break}
# site not used
}
# Find copyright repository in the appropriate language - end
# metadataRep
set metadataRep [FindMetadataRep $citedRepository]
set title [GetFieldValue $metadataRep-0 title]
set author [FormatAuthorList [GetAuthor $metadataRep-0] {;} 0 0 {&} 3]
# lappend copyrightRepositoryArray($copyrightRep) "$citedRepository - \"$title\" by $author"
lappend copyrightRepositoryArray($appropriateCopyrightRep) "$citedRepository - \"$title\" by $author"
}
}
if [info exists copyrightRepositoryArray] {
# puts copyrightRepositoryList=--[array get copyrightRepositoryArray]--
return [array get copyrightRepositoryArray]
}
# 2.
# puts 2.
# find local the copyright repositories
if {![TestContentType $repName {External Contribution}]} {
# look for the local copyright
foreach index [array names repositoryProperties *,type] {
# rep
regsub {,type} $index {} rep
if [TestContentType $rep {Local Copyright}] {
# puts rep=--$rep--
if [GetDocumentState $rep] {
# the local copyright repository is from the local collection
set list [array names referenceTable $rep,*]
# puts list=--$list--
if {[llength $list] == 0} {
# rep is not the child of any repository (i.e., it has no parents)
# found (in the first language)
# metadataRep
set metadataRep [FindMetadataRep $rep]
set title [GetFieldValue $metadataRep-0 title]
set author [FormatAuthorList [GetAuthor $metadataRep-0] {;} 0 0 {&} 3]
set copyrightRepositoryArray($rep) "$repName - \"$title\" by $author"
# puts copyrightRepositoryList=--[array get copyrightRepositoryArray]--
return [array get copyrightRepositoryArray]
}
}
}
}
}
# 3.
# puts 3.
# return the repository containing the copyright warning
set metadataRep [FindMetadataRep $repName]
set title [GetFieldValue $metadataRep-0 title]
set author [FormatAuthorList [GetAuthor $metadataRep-0] {;} 0 0 {&} 3]
set copyrightRepositoryArray($copyrightWarningRepository) "$repName - \"$title\" by $author"
return [array get copyrightRepositoryArray]
}
# FindCopyrightRepositories - end
# ----------------------------------------------------------------------
# GetLastUpdate
# Return the last update value (time stamp)
proc GetLastUpdate {rep-i {level {#0}}} {
upvar $level metadataArray metadataArray
return $metadataArray(${rep-i},lastupdate)
}
# GetLastUpdate - end
# ----------------------------------------------------------------------
# GetMetadataLastUpdate
# Return the last update value (time stamp)
proc GetMetadataLastUpdate {rep-i {level {#0}}} {
upvar $level metadataArray metadataArray
return $metadataArray(${rep-i},metadatalastupdate)
}
# GetMetadataLastUpdate - end
# ----------------------------------------------------------------------
# UpdateBase
# It is assumed that the field value was extracted from the service directory
# Example:
# UpdateBase $rep hostcollection $hostCollection
proc UpdateBase {rep fieldName fieldValue} {
# runs with post
global repositoryProperties
global saveMetadata
global homePath
# UPDATE REPOSITORY PROPERTIES
set repositoryProperties($rep,$fieldName) $fieldValue
# UPDATE METADATA
# metadataRep
set metadataRep [FindMetadataRep $rep]
if ![file isdirectory $homePath/col/$metadataRep] {
set metadataRep {}
}
if {[string compare {} $metadataRep] != 0} {
# remove and add
set metadataList {}
set metadata2List {}
UpdateMetadataField $metadataRep $fieldName \
$fieldValue metadataList metadata2List
if 0 {
# commented by GJFB in 2020-08-18
RemoveMetadata $metadata2List
AddMetadata $metadataList
} else {
UpdateMetadata $metadata2List $metadataList ;# added by GJFB in 2020-08-18 - uses metadata2List and metadataList
}
set saveMetadata 1
# SAVE
SaveMetadata
# SAVE - end
}
}
# UpdateBase - end
# ----------------------------------------------------------------------
# UpdateField
# example:
# UpdateField $rep $metadataRep contenttype metadataList metadata2List
# repositoryProperties array -> metadata
# used in PerformCheck, Dialog and UpdateTargetFile only
proc UpdateField {rep metadataRep fieldName metadataListName metadata2ListName} {
# runs with start
# global repositoryProperties ;# post
global fieldNameArray
upvar $metadata2ListName metadata2List
# puts -1-$metadata2List--
upvar $metadataListName metadataList
# puts -1-$metadataList--
# => ... iconet.com.br/banon/2003/08.18.12.15.26-0,targetfile {20 - [ARTIGO][INPE] Michelly Karoline Alves Santana.jpg} ...
if [string equal {targetfile} $fieldName] {
# added by GJFB in 2021-01-21 because Get lost extra white spaces disfiguring the target file name
array set currentMetadataArray $metadataList
if [info exists currentMetadataArray($metadataRep-0,targetfile)] {
set targetFile $currentMetadataArray($metadataRep-0,targetfile)
UpdateMetadataField $metadataRep $fieldName $targetFile metadataList metadata2List 1
} else {
DeleteMetadataField $metadataRep $fieldName metadata2List 1
}
} else {
set indexName [lindex $fieldNameArray($fieldName) 2]
if [Info exists repositoryProperties($rep,$indexName)] {
set value [Get repositoryProperties($rep,$indexName)]
if {$fieldName == "language"} {
regexp {\[(.*)\]} $value m value ;# English {[en]} -> en
}
# puts $value
# => 20 - {[ARTIGO][INPE]} Michelly Karoline Alves Santana.jpg
# the braces were added and the second white space before Michelly was lost when using Get (which use GetReply)
if {$fieldName == "targetfile"} {
set value [join $value] ;# {RBMET_SAULO[1].pdf} -> RBMET_SAULO[1].pdf - braces appear while executing: lappend replyList $reply, within GetReply
}
# puts $value
# => 20 - [ARTIGO][INPE] Michelly Karoline Alves Santana.jpg
UpdateMetadataField $metadataRep $fieldName $value metadataList metadata2List 1
} else {
DeleteMetadataField $metadataRep $fieldName metadata2List 1
}
}
}
# UpdateField - end
# ----------------------------------------------------------------------
# GetValue
# Example:
# GetValue repositoryProperties($rep,type)
proc GetValue {varName} {
global repositoryProperties ;# used remotely by start
global referenceTable ;# used remotely by start
global metadataArray ;# used remotely by start (see CreateIdentificationKey via Get)
global repArray ;# used remotely by start
global saveMetadata ;# used remotely by start
global startApplicationInUse ;# used remotely by start
global environmentArray ;# used by get.tcl
# return [subst $$varName]
# puts $varName
# puts [set $varName]
return [set $varName]
}
# GetValue - end
# ----------------------------------------------------------------------
# ReturnTheMostRecentVersions
# returns the five most recent versions
# example:
# set history [ReturnTheMostRecentVersions $rep]
proc ReturnTheMostRecentVersions {rep} {
# runs with post
global repositoryProperties
set history $repositoryProperties($rep,history)
set end [expr [llength $history] -1]
set begin [expr $end - 4]
return [lrange $history $begin $end]
}
# ReturnTheMostRecentVersions - end
# ----------------------------------------------------------------------
# UpdateGlobalVariable
# varName is the name of a list of repositories
# Example:
# Eval UpdateGlobalVariable indexRepList Index $rep
proc UpdateGlobalVariable {varName contentType rep} {
# runs with post
upvar #0 $varName var
# Drop the rep if it exists
if {[set i [lsearch -exact $var $rep]] != -1} {
set var [lreplace $var $i $i]
}
# Drop the rep if it exists - end
# Add the rep
if [TestContentType $rep $contentType] {
lappend var $rep
}
# Add the rep - end
}
# UpdateGlobalVariable - end
# ----------------------------------------------------------------------
# UpdateMultipleGlobalVariables
# used by PerformCheck and Dialog
proc UpdateMultipleGlobalVariables {rep} {
# runs with post
## Update indexRepList
## indexRepList is used for making access statistics
# Migration 15/9/07
if 1 {
UpdateGlobalVariable indexRepList Index $rep
}
# Migration 15/9/07 - end
## Update indexRepList - end
# Update bannerSequenceRepList
UpdateGlobalVariable bannerSequenceRepList {Banner Sequence} $rep
# Update bannerSequenceRepList - end
# Update officialIconRepList
UpdateGlobalVariable officialIconRepList {Access Icon} $rep
# Update officialIconRepList - end
# Update bannerPathArray
if [TestContentType $rep {Banner Sequence}] {
LoadBannerPathArray
}
# Update bannerPathArray - end
}
# UpdateMultipleGlobalVariables - end
# ----------------------------------------------------------------------
# ReturnNumberOfMetadataRep
# example:
# set numberOfmetadataRep [Eval ReturnNumberOfMetadataRep]
proc ReturnNumberOfMetadataRep {} {
# runs with post
global metadataArray
return [llength [array names metadataArray *,repository]]
}
# ReturnNumberOfMetadataRep - end
# ----------------------------------------------------------------------
# LoadTextLog
proc LoadTextLog {} {
# runs with start and post
global textLog
global homePath
global URLibServiceRepository
if [file exists $homePath/col/$URLibServiceRepository/auxdoc/textLog] {
Load $homePath/col/$URLibServiceRepository/auxdoc/textLog textLog
set length [llength $textLog]
set j [expr $length - 200] ;# 200 == maximum number of log lines
set textLog [lreplace $textLog 0 $j]
} else {
set textLog {}
}
}
# LoadTextLog - end
# ----------------------------------------------------------------------
# StoreTextLog
proc StoreTextLog {} {
# runs with start and post
global textLog
global homePath
global URLibServiceRepository
if [info exists textLog] {
Store textLog $homePath/col/$URLibServiceRepository/auxdoc/textLog
}
}
# StoreTextLog - end
# ----------------------------------------------------------------------
# LoadEnvironmentArray
# used in SPOK only
proc LoadEnvironmentArray {} {
# runs with post
global environmentArray
# source ../auxdoc/.environmentArray.tcl
SourceWithBackup ../auxdoc/.environmentArray.tcl environmentArray ;# added by GJFB in 2010-08-05
}
# LoadEnvironmentArray - end
# ----------------------------------------------------------------------
# CreateLanguageTable
proc CreateLanguageTable {} {
# runs with start and post
# runs with start only at installation
global referenceTable
global repositoryProperties
global englishRepository
global homePath
global environmentArray
# global languageList
# global languageTable
# languageRepositories (list of language repositories)
set languageRepositories $englishRepository
foreach index [array names referenceTable *,$englishRepository] {
regsub {,.*} $index {} rep
if [info exists repositoryProperties($rep,targetfile)] {
set targetFile $repositoryProperties($rep,targetfile)
if [regexp {Language.tcl} $targetFile] {
lappend languageRepositories $rep
}
}
}
set languageList {}
foreach languageRepository $languageRepositories {
set pathFile [glob -nocomplain $homePath/col/$languageRepository/doc/*Language.tcl]
regexp {.*/(.*)Language.tcl} $pathFile m language
set language2 $language
if [string equal {Portuguese} $language] {set language2 {Português}}
lappend languageList $language2
set languageTable($language2) $languageRepository
}
if {[lsearch -exact $languageList $environmentArray(spLanguageEntry)] == -1} {
set environmentArray(spLanguageEntry) English
}
# puts $languageList
return [array get languageTable]
}
# CreateLanguageTable - end
# ----------------------------------------------------------------------
# CreateMirrorLanguageTable
proc CreateMirrorLanguageTable {} {
global englishMirrorRepository
global portugueseBrasilMirrorRepository
set languageTable(English) $englishMirrorRepository
# set languageTable(Português) $portugueseBrasilMirrorRepository
set languageTable(Portuguese) $portugueseBrasilMirrorRepository
return [array get languageTable]
}
# CreateMirrorLanguageTable - end
# ----------------------------------------------------------------------
# CheckModifiedTime
# returns one of the values: Modified Unchanged Unchecked
# Unchanged means that
# the lastupdate in the file system == lastupdate in the metadata
#
# seconds is the mTime of the repository ($rep) being checked
# seconds is given by DirectoryMTime or RepositoryMTime; examples:
# set seconds [DirectoryMTime $homePath/col/$rep/doc 1]
# set seconds [Eval RepositoryMTime $rep $homePath 1]
#
# metadataRep and versionStamp may be given by:
# set metadataRep [FindMetadataRep $rep]
# set versionStamp [GetLastUpdate $metadataRep-0]
#
# works with gmt
# new code - adapted to migration reality (+ 1 second) and to clock ajustment for daylight saving (+- 3600 seconds or +- 7200 secconds) - by GJFB in 2010-11-23
# IR in banon-pc3 of sid.inpe.br/mtc-m12@80/2006/11.30.18.29 from m12
proc CheckModifiedTime {rep seconds {metadataRep none} {versionStamp none}} {
global homePath
# set seconds [DirectoryMTime $homePath/col/$rep/doc 1]
if {$seconds == ""} {
# repository content too big
return Unchecked
}
if {$metadataRep == "none"} {set metadataRep [FindMetadataRep $rep]}
if {$metadataRep == ""} {return Unchecked}
# lastChange1 (in the file system)
set lastChange1 $seconds
# lastChange2 (registered in the metadata)
if {$versionStamp == "none"} {set versionStamp [GetLastUpdate $metadataRep-0]}
if {[info tclversion] > 8.4} {
set lastChange2 [clock scan [lindex $versionStamp 0] -format %Y:%m.%d.%H.%M.%S -gmt 1]
} else {
set monthTable(01) Jan
set monthTable(02) Feb
set monthTable(03) Mar
set monthTable(04) Apr
set monthTable(05) May
set monthTable(06) Jun
set monthTable(07) Jul
set monthTable(08) Aug
set monthTable(09) Sep
set monthTable(10) Oct
set monthTable(11) Nov
set monthTable(12) Dec
regexp {(....):(..)\.(..)\.(..)\.(..)\.(..)} [lindex $versionStamp 0] match Y m d H M S
set lastChange2 [clock scan "$monthTable($m) $d $H:$M:$S $Y" -gmt 1]
}
set lastChange2List $lastChange2
lappend lastChange2List [expr $lastChange2 + 1]
lappend lastChange2List [expr $lastChange2 + 3600]
lappend lastChange2List [expr $lastChange2 + 3601]
lappend lastChange2List [expr $lastChange2 + 7200]
lappend lastChange2List [expr $lastChange2 + 7201]
lappend lastChange2List [expr $lastChange2 - 3600]
lappend lastChange2List [expr $lastChange2 - 3599]
lappend lastChange2List [expr $lastChange2 - 7200]
lappend lastChange2List [expr $lastChange2 - 7199]
# set xxx [list lastChange2 = $lastChange2 lastChange1 = $lastChange1]
# Store xxx C:/tmp/bbb.txt auto 0 a
# set xxx [list lastChange2List = $lastChange2List lastChange1 = $lastChange1]
# Store xxx C:/tmp/bbb.txt auto 0 a
if {[lsearch $lastChange2List $lastChange1] == -1} {
# modified version
return Modified
} else {
# unchanged version
return Unchanged
}
}
# not used - old code
proc CheckModifiedTime2 {rep seconds {metadataRep none} {versionStamp none}} {
global homePath
# set seconds [DirectoryMTime $homePath/col/$rep/doc 1]
if {$seconds == ""} {
# repository content too big
return Unchecked
}
if {$metadataRep == "none"} {set metadataRep [FindMetadataRep $rep]}
if {$metadataRep == ""} {return Unchecked}
# lastChange1 (in the file system)
set lastChange1 [clock format $seconds -format %Y:%m.%d.%H.%M.%S -gmt 1]
# lastChange2 (registered in the metadata)
if {$versionStamp == "none"} {set versionStamp [GetLastUpdate $metadataRep-0]}
set lastChange2 [lindex $versionStamp 0]
# set xxx [list lastChange2 = $lastChange2 lastChange1 = $lastChange1]
# Store xxx C:/tmp/bbb.txt auto 0 a
if {$lastChange2 != "$lastChange1"} {
# modified version
return Modified
} else {
# unchanged version
return Unchanged
}
}
# CheckModifiedTime - end
# ----------------------------------------------------------------------
# ComputeVersionState
# computes the version state of the currentRep
# if completeDiagnosis is 0
# returns one of the state values:
# Registered Original
# Modified Original
# Copy of an Original
# Modified Copy of an Original
# Unchecked
# Registered Original means that the host collection of currentRep is
# the current local collection and the repository content has not be modified
# if completeDiagnosis is 1 (used by Cover)
# returns one of the state values:
# Registered Original
# Modified Original
# Copy of the Registered Original
## Copy of a Previously Registered Original
# Copy of an Original
# Modified Copy of an Original
# Unchecked
#
# if state is Registered Original
# officialSite contains the serverAddress of the site containing the original
# otherwise officialSite is empty
#
# used in:
# GetMetadataRepositories (utilitiesMirror.tcl)
# CreateSiteEntry (utilitiesMirror.tcl)
# CreateBriefEntry (utilitiesMirror.tcl)
# GetLanguageRepositories (utilitiesMirror.tcl)
# GetURLPropertyList (utilitiesMirror.tcl)
# Cover (used completeDiagnosis == 1)
# siteListRep not used
# deletes download/doc.zip whenever the state value contains the word Modified
proc ComputeVersionState {currentRep {siteListRep {}} {completeDiagnosis 0}} {
# runs with post
global serverAddress
global homePath
global loCoInRep
global defaultAccessIconRepository
global repositoryProperties
set state {Unchecked}
set officialSite {}
set imageURL http://[ReturnHTTPHost]/rep-/$defaultAccessIconRepository
# Store imageURL C:/tmp/bbb auto 0 a
# puts $currentRep
if [info exists repositoryProperties($currentRep,numberoffiles)] {
set numberOfFiles $repositoryProperties($currentRep,numberoffiles)
# puts $numberOfFiles
if {$numberOfFiles > 850} {
# two many files (RepositoryMTime is time consuming)
return [list $state $officialSite $imageURL]
} else {
set seconds [RepositoryMTime $currentRep $homePath 1]
}
} else {
# no number of files
set seconds [RepositoryMTime $currentRep $homePath 1]
}
set metadataRep [FindMetadataRep $currentRep]
if {$metadataRep == ""} {
return [list $state $officialSite $imageURL]
}
# versionStamp
set versionStamp [GetLastUpdate $metadataRep-0]
# set xxx [list command = CheckModifiedTime $currentRep $seconds $metadataRep $versionStamp]
# puts $xxx
# Store xxx C:/tmp/bbb.txt auto 0 a
set check [CheckModifiedTime $currentRep $seconds $metadataRep $versionStamp]
# set xxx [list check = $check]
# puts $xxx
# Store xxx C:/tmp/aaa auto 0 a
if [regexp Unchecked $check] {
return [list $state $officialSite $imageURL]
}
# lastHostCollection
set lastHostCollection [lindex [LoadHostCollection $currentRep] end]
if 0 {
# officialIconRep
set officialIconRep [GetOfficialIconRep]
if {$officialIconRep == ""} {
# the official icon has not been created for this site
set officialIconRep $defaultAccessIconRepository
}
}
# set state {}
if [regexp Modified $check] {
# Modified
if {$lastHostCollection == "$loCoInRep"} {
# the host collection of currentRep is the current local collection
# >>> Modified Original
set state {Modified Original}
} else {
# the host collection of currentRep is not the current local collection
# >>> Modified Copy of an Original
set state {Modified Copy of an Original}
}
} else {
# Unchanged
## Look for official version
if {$lastHostCollection == "$loCoInRep"} {
# the host collection of currentRep is the current local collection
# set state Official
# >>> Registered Original
set state {Registered Original}
set officialSite $serverAddress
if {![TestContentType $currentRep {External Contribution}] \
&& ![TestContentType $currentRep {Copyright}]} {
set officialIconRep [GetOfficialIconRep]
if {$officialIconRep != ""} {
# the official icon has been created for this site
set imageURL http://[ReturnHTTPHost]/rep-/$officialIconRep
}
}
} else {
# the host collection of currentRep is not the current local collection
if $completeDiagnosis {
set officialSite [FindSiteContainingTheOriginal2 $currentRep] ;# with ip
if [string equal {} $officialSite] {
# official site not found
# >>> Copy of an Original
set state {Copy of an Original}
} else {
# official site found
set versionState [Execute $officialSite [list ComputeVersionState $currentRep]]
if [string equal {} $versionState] {
# official site is not returning - (for example when using banon-pc3 with INPE wireless and trying to open an administrator page using Get) - GJFB in 2010-12-06
set state {Copy of an Original}
} else {
foreach {state2 officialSite imageURL} $versionState {break}
if [string equal {Registered Original} $state2] {
# set versionStamp2 [Execute $officialSite [list GetLastUpdate $metadataRep-0]]
if [catch {Execute $officialSite [list GetLastUpdate $metadataRep-0]} versionStamp2] {
# example of error message:
# Execute: communication with server banon-pc3 800 [banon-pc3 800] doesn't start
set state {Copy of an Original}
} else {
if {$versionStamp == "$versionStamp2"} {
# >>> Copy of the Registered Original
set state {Copy of the Registered Original}
} else {
## >>> Copy of a Previously Registered Original
# set state {Copy of a Previously Registered Original}
# >>> Copy of an Original
set state {Copy of an Original}
}
}
} else {
## >>> Copy of a Previously Registered Original
# set state {Copy of a Previously Registered Original}
# >>> Copy of an Original
set state {Copy of an Original}
}
}
}
} else {
# >>> Copy of an Original
set state {Copy of an Original}
}
}
## Look for official version - end
}
array set stateTable {
{Registered Original} {Official}
{Modified Original} {Modified}
{Copy of the Registered Original} {Official}
{Copy of an Original} {Copied}
{Modified Copy of an Original} {Modified}
{Unchecked} {Unchecked}
}
if [string equal {Modified} $stateTable($state)] {
file delete $homePath/col/$currentRep/download/doc.zip ;# added by GJFB in 2012-12-25 - needed because the download/doc.zip is not automatically updated when an UpdateLastUpdate is done (resulting in out-of-date doc.zip)
}
return [list $state $officialSite $imageURL]
}
# ComputeVersionState - end
# ----------------------------------------------------------------------
# GetPermission
# directory value is doc or download
proc GetPermission {directory} {
# runs with post
global environmentArray
regsub {d} $directory {D} directory
return [lindex [split $environmentArray(sp${directory}AccessPermission) \n] end]
}
# GetPermission - end
# ----------------------------------------------------------------------
# Migrate1
# Migrates from Version 1 to Version 2
# Creates a metadata repository if it doesn't exist
proc Migrate1 {rep} {
# runs with post
global homePath
global bib2referRepository
global saveMetadata
global loCoInRep
global tcl_platform
if {$tcl_platform(platform) == "unix" && \
[file isdirectory $homePath/col/$rep/bib] && \
![file isdirectory $homePath/col/$rep/service]} {
# rep is of Version 1
set path1 [eval file join [lrange [file split $rep] 0 2]]
set path2 [lindex [file split $rep] end]
set firstCharacter [string index [exec ls -l $homePath/col/$path1 | grep $path2] 0]
if {$firstCharacter == "d"} {
set metadataRep [FindMetadataRep $rep]
if ![file isdirectory $homePath/col/$metadataRep] {
# UpdateVariables $metadataRep
set metadataRep {}
}
set bibPath [glob $homePath/col/$rep/bib/*/a.bib]
regsub {/a.bib$} $bibPath {} bibPath
if {$metadataRep == {}} {
if ![file isdirectory $homePath/col/$rep/service] {
file mkdir $homePath/col/$rep/auxdoc
file mkdir $homePath/col/$rep/source
file mkdir $homePath/col/$rep/service
# size and numberOfFiles
# set size [ComputeSize $rep]
foreach {size numberOfFiles} [ComputeInfo $rep] {break}
Store size $homePath/col/$rep/service/size
Store numberOfFiles $homePath/col/$rep/service/numberOfFiles
# hostCollection
StoreHostCollection $rep $loCoInRep
# history
# CREATE A NEW VERSION STAMP
set seconds [DirectoryMTime $homePath/col/$rep/doc]
set versionStamp [CreateVersionStamp $seconds]
UpdateHistory $rep $versionStamp
# reference
Load $homePath/col/$rep/.reserved/ref reference
set referenceList1 [split $reference \n]
if {$referenceList1 != {}} {
set referenceList2 {}
foreach ref $referenceList1 {
lappend referenceList2 ../../../../../../col/$ref
}
set reference [join $referenceList2 \n]
Store reference $homePath/col/$rep/service/reference
}
}
# no metadataRep exists
# create a metadata repository
Load $bibPath/a.bib bibTeXEntry
set referEntry [${bib2referRepository}::Bib2Refer $bibTeXEntry]
regsub {(%0[^%]*)} $referEntry "\\1%4 $rep\n" referEntry
set metadataList [LoadMetadata $referEntry] ;# startApacheServer
# AddMetadata $metadataList ;# commented by GJFB in 2020-08-18
AddMetadata2 $metadataList ;# added by GJFB in 2020-08-18
set saveMetadata 1
}
}
return 0
} else {
return 1
}
}
# Migrate1 - end
# ----------------------------------------------------------------------
# Migrate2
# Migrates from Version 1 to Version 2
# Updates the metadata in both versions
# was used in PerformCheck
proc Migrate2 {rep} {
# runs with post
global homePath
global bib2referRepository
if [file isdirectory $homePath/col/$rep/bib] {
# rep is of Version 1
set metadataRep [FindMetadataRep $rep]
if ![file isdirectory $homePath/col/$metadataRep] {
# UpdateVariables $metadataRep
set metadataRep {}
}
set bibPath [glob $homePath/col/$rep/bib/*/a.bib]
regsub {/a.bib$} $bibPath {} bibPath
if {$metadataRep != {}} {
# a metadataRep exists
set seconds1 [DirectoryMTime $bibPath]
set referPath $homePath/col/$metadataRep/doc
set seconds2 [DirectoryMTime $referPath]
if [expr abs($seconds1 - $seconds2) > 10] {
# the versions are different
if {$seconds1 < $seconds2} {
# update Version 1
Load $referPath/@metadata.refer referEntry
set metadataList [ConvertRefer2MetadataList $referEntry $metadataRep 0]
set rep-i $metadataRep-0
set bibTeXEntry { Bibligraphic index {}}
foreach item [CreateBibTeXEntry $metadataList ${rep-i}] {
if [regexp {metadatarepository =| repository =} $item] {continue}
lappend bibTeXEntry $item
}
lappend bibTeXEntry {}
lappend bibTeXEntry {}
set bibTeXEntry [join $bibTeXEntry \n]
Store bibTeXEntry $bibPath/a.bib
} else {
# update Version 2
Load $bibPath/a.bib bibTeXEntry
set referEntry [${bib2referRepository}::Bib2Refer $bibTeXEntry]
regsub {(%0[^%]*)} $referEntry "\\1%4 $rep\n" referEntry
regsub {(%0[^%]*)} $referEntry "\\1%2 $metadataRep\n" referEntry
}
# store Version 2 anyway
Store referEntry $referPath/@metadata.refer
}
}
}
}
# Migrate2 - end
# ----------------------------------------------------------------------
# BackupRegisteredVersion
# used in MakeDownloadFile
proc BackupRegisteredVersion {rep} {
# runs with post
global col
global repositoryProperties
if [file exists $col/$rep/download/doc.zip] {
if [file exists $col/$rep/download/sample] {
if [file exists $col/$rep/download/time] {
# Backup the old registered version
set history $repositoryProperties($rep,history)
set historyLength [llength $history]
set versionStamp [lindex $history [expr $historyLength - 2]]
regsub -all {[:/]} $versionStamp {=} versionStamp
file mkdir $col/$rep/backup/$versionStamp
file copy $col/$rep/download/doc.zip $col/$rep/backup/$versionStamp/doc.zip
file copy $col/$rep/download/sample $col/$rep/backup/$versionStamp/sample
file copy $col/$rep/download/history $col/$rep/backup/$versionStamp/history
file copy $col/$rep/download/time $col/$rep/backup/$versionStamp/time
# Backup the old registered version - end
}
file delete $col/$rep/download/sample
file delete $col/$rep/download/history
file delete $col/$rep/download/time
}
# file delete $col/$rep/download/doc.zip ;# commented in 2010-07-04
}
}
# BackupRegisteredVersion - end
# ----------------------------------------------------------------------
# MakeDownloadFile
# packEverything value is 0, 1 or 2
# 0 means to pack just doc, agreement, images and part of service
# 1 means to pack everything (i.e., besides doc, agreement, images and part of service, source, backup and not_sent directories)
# 2 means to pack everything except doc, agreement and images
# force value is 0 or 1
# 1 means to execute TestUpdateLastUpdate even for $rep
# backup value is 0 or 1
# 1 means that the current version must be registered and then back it up
# userName used by TestUpdateLastUpdate (called by ComputeRepositoryList) to create the version stamp
## dontMakeIfItExists not used any more after 2020-04
## dontMakeIfItExists value is 0 (default) or 1
## 1 means to don't make the download file if it already exists
## used only in:
## iconet.com.br/banon/2002/02.04.12.37
## iconet.com.br/banon/2002/02.02.20.42
## iconet.com.br/banon/2002/02.02.09.41
# used only in:
# Script (dpi.inpe.br/banon-pc@1905/2005/02.19.00.40) option 14 - Reload last update
# Download called by clicking export
# ExtractURLibService
# UpdateDownloadFile called by UpdateDownloadFilesByAdministrator called by Dialog, PerformCheck and TransferCopyright
# UpdateDownloadFile called in DDOK and StartService
# ImportRepository
# LoadBiblioDB
proc MakeDownloadFile {
rep {packEverything 0} {force 0} {backup 0} {userName {}} {dontMakeIfItExists 0}
} {
# runs with post
global homePath
global pwd
# global referenceTable ;# commented by GJFB in 2015-04-18
global URLibServiceRepository
# global downloadingEnvironmentRepository ;# not used any more after 2020-04
# global samplingRepository
# global repositoryProperties ;# commented by GJFB in 2015-04-18
# global downloadForWindowsRepository ;# not used any more after 2020-04
# global downloadForSunOSRepository ;# not used any more after 2020-04
# global downloadForLinuxRepository ;# not used any more after 2020-04
global zipPath
# global tcl_platform
if {$dontMakeIfItExists && [file exists $homePath/col/$rep/download/doc.zip]} {return}
# set xxx [CallTrace]
# Store xxx C:/tmp/bbb.txt auto 0 a
# puts $packEverything
set currentDownloadPermission [FindCurrentDownloadPermission $rep]
# puts --$currentDownloadPermission--
if {!$backup && [string equal $currentDownloadPermission {deny from all}]} {
file delete $homePath/col/$rep/download/doc.zip
file delete $homePath/col/$rep/download/history
file delete $homePath/col/$rep/download/sample
return
}
file delete $homePath/col/$URLibServiceRepository/doc/core ;# delete core file (if any)
file mkdir $homePath/col/$rep/download
# Compute repositoryList
# set repositoryList [ComputeRepositoryList $rep $force] ;# parent repositories + $rep + metadata repositories
set repositoryList [ComputeRepositoryList $rep $force $userName] ;# parent repositories + $rep + metadata repositories
# puts --$repositoryList--
# Compute repositoryList - end
Store repositoryList $homePath/repositoryList
# if {$tcl_platform(platform) == "unix"} #
# if [file owned $zipPath] {exec chmod 774 $zipPath} ;# must be executable
# #
set command "$zipPath"
set option "-r"
set type zip
# file delete $homePath/col/$rep/download/doc.$type
BackupRegisteredVersion $rep
if {$packEverything != 2} {
file delete $homePath/col/$rep/download/doc.zip
}
# Compute fileList1 and fileList2 (could be one list)
set fileList1 {} ;# just for doc
set fileList2 {} ;# for the rest (except service)
foreach repository $repositoryList {
# lappend fileList1 col/$repository/doc ;# commented by GJFB in 2013-02-09 - see new code below
if [file isdirectory $homePath/col/$repository/agreement] {
lappend fileList1 col/$repository/agreement
}
if [file isdirectory $homePath/col/$repository/images] {
lappend fileList1 col/$repository/images
}
# Preserve the administrator as an advanced user
LoadService $repository userName userName 1 1
if [string equal {administrator} $userName] {
# user name is administrator
set userNamePath {} ;# don't exclude (see below) - useful for administrator pages
} else {
set userNamePath col/$repository/service/userName
}
# Preserve the administrator as an advanced user - end
if 0 {
# commented by GJFB in 2018-09-08 - see below
# Preserve the administrator as a user (authenticated user) - added by GJFB in 2018-06-02
LoadService $repository authenticatedUsers authenticatedUsers 0 1
if [string equal {administrator} $authenticatedUsers] {
# user name is administrator
set authenticatedUsersPath {} ;# don't exclude (see below) - useful for the administrator page
} else {
set authenticatedUsersPath col/$repository/service/authenticatedUsers
}
# Preserve the administrator as an advanced user - end
}
cd $homePath
# if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" col/$repository/service -x col/$repository/service/registrationPassword $userNamePath col/$repository/service/authenticatedUsers col/$repository/service/accessLog"} message] #
# ZIP (part of service)
# if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" col/$repository/service -x col/$repository/service/hostCollection col/$repository/service/transferableFlag $userNamePath col/$repository/service/authenticatedUsers col/$repository/service/accessLog"} message] # ;# commented by GJFB in 2018-06-02
# if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" col/$repository/service -x col/$repository/service/hostCollection col/$repository/service/transferableFlag $userNamePath $authenticatedUsersPath col/$repository/service/accessLog"} message] # ;# added by GJFB in 2018-06-02 - useful for the administrator page - commented by GJFB in 2018-09-08
if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" col/$repository/service -x col/$repository/service/hostCollection col/$repository/service/transferableFlag $userNamePath col/$repository/service/accessLog"} message] { ;# added by GJFB in 2018-09-08 - it seems convenient not to exclude any members of the reader group
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MakeDownloadFile (1): $message\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
if {$packEverything != 2} {
# ZIP (part of doc) - added by GJFB in 2013-02-09 to exclude doc/tmp - updated by GJFB in 2020-04-18 to exclude doc/progressDir
if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" col/$repository/doc -x col/$repository/doc/tmp/* col/$URLibServiceRepository/doc/progressDir/*"} message] {
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MakeDownloadFile (1): $message\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
cd $pwd
if $packEverything {
if ![TestContentType $rep Metadata] {
if [file isdirectory $homePath/col/$repository/source] {
lappend fileList2 col/$repository/source
}
if [file isdirectory $homePath/col/$repository/backup] {
lappend fileList2 col/$repository/backup
}
if [file isdirectory $homePath/col/$repository/not_sent] {
lappend fileList2 col/$repository/not_sent
}
if [file exists $homePath/col/$repository/download/sample] {
lappend fileList2 col/$repository/download/sample
}
if [file exists $homePath/col/$repository/download/history] {
lappend fileList2 col/$repository/download/history
}
if [file exists $homePath/col/$repository/download/time] {
lappend fileList2 col/$repository/download/time
}
}
}
}
# if {$rep == "$URLibServiceRepository" || \
# $rep == "$downloadForWindowsRepository" || \
# $rep == "$downloadForSunOSRepository" || \
# $rep == "$downloadForLinuxRepository" || \
# $rep == "$downloadingEnvironmentRepository"} #
if {$rep == "$URLibServiceRepository"} {
if [file exists $homePath/newVersion] {lappend fileList2 newVersion}
if [file exists $homePath/start] {lappend fileList2 start} ;# added by GJFB in 2020-05-24
}
# if {$rep == "$downloadForSunOSRepository" || \
# $rep == "$downloadForLinuxRepository" || \
# $rep == "$downloadingEnvironmentRepository"} {
# lappend fileList2 start ;# start script for UNIX
# }
if 0 {
# shortcut cannot be zipped
if {$rep == "$downloadForWindowsRepository"} { ;# added by GJFB in 2017-10-14
lappend fileList2 {"post URLib"} ;# atalho para c:\URLib
lappend fileList2 {"unpost URLib"} ;# atalho para c:\URLib
lappend fileList2 {"start URLib"} ;# atalho para c:\URLib
lappend fileList2 {"update URLib"} ;# atalho para c:\URLib
lappend fileList2 {"reset URLib"} ;# atalho para c:\URLib
}
}
lappend fileList2 packedRepository ;# used by IR
lappend fileList2 packedRepositoryVersion ;# used by IR
lappend fileList2 repositoryList ;# used by IR
# Compute fileList1 and fileList2 - end
# Store packedRepository and packedRepositoryVersion
# must be after ComputeRepositoryList
set packedRepository $rep
Store packedRepository $homePath/packedRepository
# set packedRepositoryVersion [lindex $repositoryProperties($rep,history) end]
# set packedRepositoryVersion [GetVersionStamp $rep] ;# commented by GJFB in 2020-04-22
Load $homePath/col/$rep/service/history history
set packedRepositoryVersion [lindex $history end] ;# added by GJFB in 2020-04-22 - GetVersionStamp cannot be used here because when calling MakeDownloadFile in ExtractURLibService the global variable repositoryProperties (used in GetVersionStamp) is not updated yet
Store packedRepositoryVersion $homePath/packedRepositoryVersion
# Store packedRepository and packedRepositoryVersion - end
cd $homePath
if {$packEverything != 2} {
## ZIP (doc, agreement and images) ;# commented by GJFB in 2013-02-09
# ZIP (agreement and images)
# -x col/$repository/service/hostCollection
if ![string equal {} $fileList1] {
if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" $fileList1"} message] {
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MakeDownloadFile (2): $message\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
}
# ZIP (source and others)
if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" $fileList2"} message] {
## puts "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" [join $fileList2]"
# if [catch {eval "exec \"$command\" $option \"$homePath/col/$rep/download/doc.$type\" [join $fileList2]"} message] # ;# added by GJFB in 2017-10-14 - {"unpost URLib"} {"post URLib"} -> "unpost URLib" "post URLib"
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] MakeDownloadFile (3): $message\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
# puts source
cd $pwd
# set xxx [list $rep done]
# Store xxx C:/tmp/aaa auto 0 a
}
# MakeDownloadFile - end
# ----------------------------------------------------------------------
# ComputeRepositoryList
# includes parent repositories + $rep + metadata repositories
# force value is 0 or 1
# 1 means to execute TestUpdateLastUpdate even for $rep
# userName used by TestUpdateLastUpdate to create the version stamp
# used in MakeDownloadFile only
proc ComputeRepositoryList {rep force {userName {}}} {
# runs with post
global saveMetadata
global col
set repositoryList [CreateCitedRepositoryList $rep] ;# all parent repositories (inclusive parents of parents)
# Exclude non original parents of an original document
# useful when testing the INPE bibliografic mirror in gjfb.home
# in m19 (where is the INPE bibliografic mirror is the original) the parent: dpi.inpe.br/banon/1999/05.03.22.11 is not the original and must be part of the download file for exportation
# added by GJFB in 2015-07-04
if [GetDocumentState $rep] {
# the document is the original
set repositoryList2 {}
foreach rep2 $repositoryList {
if [GetDocumentState $rep2] {
# the document is the original
lappend repositoryList2 $rep2 ;# just append original document
} else {
puts $rep2
}
}
set repositoryList $repositoryList2
}
# Exclude non original parents of an original document - end
lappend repositoryList $rep
if ![info exists saveMetadata] {set saveMetadata 0}
foreach repName $repositoryList {
set metadataRep [FindMetadataRep $repName]
if {$metadataRep != {}} {
set languageVersions [FindAllLanguageVersions $metadataRep]
foreach mRep $languageVersions {
lappend repositoryList $mRep
}
if {$force || ![string equal $rep $repName]} {
# set newer [TestUpdateLastUpdate $repName $metadataRep 1 $userName]
set newer [TestUpdateLastUpdate $repName $metadataRep 1 $userName 0] ;# don't update child last update - added by GJFB in 2010-08-20
set saveMetadata [expr $saveMetadata || $newer]
if {$newer && ![string equal $rep $repName]} {
# set xxx parent
# Store xxx C:/tmp/aaa auto 0 a
# UpdateDownloadFile $repName ;# may set saveMetadata to 1
UpdateDownloadFile $repName 0 0 $userName ;# may set saveMetadata to 1
}
}
}
}
return $repositoryList
}
# ComputeRepositoryList - end
# ----------------------------------------------------------------------
# UpdateCitingItemList
# added by GJFB in 2024-01-04
# updated by GJFB in 2024-01-21
# used in CountOneClick OR DeleteRepository only
# source is the repository of the citing item (source object)
# destination is the repository of the cited item (destination object)
# used by robust hyperlinks
# updateType value is add or remove
proc UpdateCitingItemList {source destination updateType} {
# runs with post of the local collection destination
global homePath
if [file exists $homePath/col/$destination/service/citingItemList] {
source $homePath/col/$destination/service/citingItemList ;# citingArray
set flag [info exists citingArray()] ;# migration 2024-02-08
if $flag { ;# migration 2024-02-08 - clean the empty entry of citingArray that has been added before adding the if command below
unset citingArray()
}
} else {
set flag 0 ;# migration 2024-02-08
}
if [string equal {} $source] {
# added by GJFB in 2024-02-08 - required because of the new citingItem optional argument of PostponeOneClickCount used in AcknowledgeArchive
# return
if !$flag {return} ;# migration 2024-02-08
} else {
if [string equal {add} $updateType] {
# add
incr citingArray($source)
} else {
# remove
if [info exists citingArray($source)] {
unset citingArray($source)
if [string equal {} [array names citingArray]] {
file delete $homePath/col/$destination/service/citingItemList ;# added by GJFB in 2024-04-27
return
}
} else {
set log "citingArray($source) not found"
StoreLog {notice} {UpdateCitingItemList} $log
}
}
}
StoreArray citingArray $homePath/col/$destination/service/citingItemList w array array 1
# Reduce to the 6 most frequent citing
# same code in CreateExtraFields
set citingList {}
foreach {repository frequency} [array get citingArray] {
lappend citingList [list $repository $frequency]
}
set value [lrange [lsort -integer -decreasing -index 1 $citingList] 0 5]
# Reduce to the 6 most frequent citing - end
set metadataRep [FindMetadataRep $destination]
set metadata2List {}
set metadataList {}
UpdateMetadataField $metadataRep citingitemlist $value metadataList metadata2List 1
UpdateMetadata $metadata2List $metadataList
UpdateRepositoryListForPost $destination
}
# UpdateCitingItemList - end
# ----------------------------------------------------------------------
# CountOneClick
# URParts example: dpi.inpe.br banon 1998 08.02.08.56
# citingItem is the repository of the source object in a Robust Hyperlink - added by GJFB in 2024=01-04
proc CountOneClick {URParts clientIPAddress {citingItem {}}} {
# runs with post
global col
global homePath
global URLibServiceRepository
# global serverAddressWithIP
# set xxx [CallTrace]
# Store xxx C:/tmp/bbb.txt auto 0 a
# set x 0; after 3000 {set x 1}; vwait x ;# just for comparing execution time with Get-
set rep [join $URParts /]
if [GetDocumentState $rep] {
# the original document
# Waiting for the completion of other CountOneClick
WaitQueue CountOneClick $rep
# Waiting for the completion of other CountOneClick - end
if ![TestContentType $rep "Mirror"] { ;# if added by GJFB in 2025-06-15 to avoid adding citing item in a mirror when pressing the return green button with option 'no return path and child' and when forcehistorybackflag is 0
UpdateCitingItemList $citingItem $rep add ; # added by GJFB in 2024-01-04 to turn persistent hyperlings robust
}
set day [clock format [clock seconds] -format %Y.%m.%d]
if [file exists $homePath/col/$rep/service/clientIPLog] {
source $homePath/col/$rep/service/clientIPLog ;# set clientIPArray
# array get clientIPArray
# =>
# 2015.05.05 {192.168.1.31} 2015.05.06 {192.168.1.31 192.168.1.32}
}
if [info exists clientIPArray($day)] {
# not the first click of the day
if {[set index [lsearch $clientIPArray($day) $clientIPAddress]] == -1} {
# ip doesn't exist
lappend clientIPArray($day) $clientIPAddress
StoreArray clientIPArray $homePath/col/$rep/service/clientIPLog w list array 1
}
} else {
# first click of the day
set index -1 ;# ip doesn't exist
set clientIPArray($day) $clientIPAddress
StoreArray clientIPArray $homePath/col/$rep/service/clientIPLog w list array 1
}
if {$index == -1} {
# the ip is new for the current day - count on click
# UpdateCitingItemList $citingItem $rep add ; # added by GJFB in 2024-01-04 to turn persistent hyperlings robust
if [file exists $homePath/col/$rep/service/accessLog] {
# not the first click
Load $homePath/col/$rep/service/accessLog fileContent
set lineList [split $fileContent \n]
set lastLine [lindex $lineList end]
if [regexp "^$day" $lastLine] {
# not the first click of the day
regexp {(.*)-(.*)} $lastLine m day numberOfClicks
incr numberOfClicks ;# + 1
set newLastLine $day-$numberOfClicks
set lineList [lreplace $lineList end end $newLastLine]
} else {
# first click of the day
set newLastLine $day-1
lappend lineList $newLastLine
}
set fileContent [join $lineList \n]
} else {
# first click
set fileContent $day-1
}
Store fileContent $homePath/col/$rep/service/accessLog
}
LeaveQueue [pid] $rep
} else {
# not the original document
if 1 {
set siteContainingTheOriginal [FindSiteContainingTheOriginal2 $rep]
# puts --$siteContainingTheOriginal--
# sometimes the serverAddressWithIP of the site containing the original may be 127.0.0.1 in a wrong way
# this already occured after a breakdown (with marte)
# the solution to this problem was included in Execute
# warning: in standalone mode there are no click counts
if ![string equal {} $siteContainingTheOriginal] {
# if {![regexp {127.0.0.1} $siteContainingTheOriginal] && [string equal {} $siteContainingTheOriginal]} #
# if {(![regexp {127.0.0.1} $siteContainingTheOriginal] || [regexp {127.0.0.1} $serverAddressWithIP]) && \
# ![string equal {} $siteContainingTheOriginal]} #
if [catch {Execute $siteContainingTheOriginal [list PostponeOneClickCount $URParts $clientIPAddress]} message] {
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] CountOneClick:\nthe command: [list PostponeOneClickCount $URParts $clientIPAddress] cannot be executed for the following reason:\n$message\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
}
}
}
}
# CountOneClick - end
# ----------------------------------------------------------------------
# PostponeOneClickCount
# URParts example: dpi.inpe.br banon 1998 08.02.08.56
# used in CountOneClick, AcknowledgeArchive, CreateMirror and Archive only
# citingItem is the repository of the source object in a Robust Hyperlink - set in AcknowledgeArchive - added by GJFB in 2024=01-04
proc PostponeOneClickCount {URParts clientIPAddress {citingItem {}}} {
return [list $URParts $clientIPAddress $citingItem] ;# {{urlib.net www 2014 03.25.23.20} 192.168.1.31}
}
# PostponeOneClickCount - end
# ----------------------------------------------------------------------
# ReturnSiteContainingTheOriginal
# without ip (ip == 0) is used in Statistics
proc ReturnSiteContainingTheOriginal {rep {ip 1}} {
global serverAddressWithIP
global serverAddress
# puts $serverAddressWithIP
if [GetDocumentState $rep] {
# rep contains the original
if $ip {
# return $serverAddressWithIP
return [list $serverAddressWithIP]
} else {
# return $serverAddress ;# use this line for texting clearing channel (click in statistics) - see also FindSiteContainingTheOriginal
return [list $serverAddress]
}
}
}
# ReturnSiteContainingTheOriginal - end
# ----------------------------------------------------------------------
# StartApacheServerAfterSubmission
# used in ServeLocalCollection
proc StartApacheServerAfterSubmission {} {
}
# StartApacheServerAfterSubmission - end
# ----------------------------------------------------------------------
# ConvertPS2PDF
# used by Submit
proc ConvertPS2PDF {ps2pdfConverterPath repName fileName} {
global homePath
if [catch {exec $ps2pdfConverterPath $homePath/col/$repName/doc/$fileName &} message] {
return $message
}
}
# ConvertPS2PDF - end
# ----------------------------------------------------------------------
# StartPS2PDFConversionAfterSubmission
# used in ServeLocalCollection
# not used
proc StartPS2PDFConversionAfterSubmission {ps2pdfConverterPath repName} {
return [list $ps2pdfConverterPath $repName]
}
# StartPS2PDFConversionAfterSubmission - end
# ----------------------------------------------------------------------
# SaveToDisk
proc SaveToDisk {} {
# runs with post
# global referenceTable
# global repositoryProperties
# StoreArray referenceTable ../auxdoc/.referenceTable.tcl w list
# StoreArray repositoryProperties ../auxdoc/.repositoryProperties.tcl w list
SaveRepositoryProperties
SaveReferenceTable
SaveMetadata
}
# SaveToDisk - end
# ----------------------------------------------------------------------
# PostponeSaveToDisk
proc PostponeSaveToDisk {} {
}
# PostponeSaveToDisk - end
# ----------------------------------------------------------------------
# ReturnTargetFileContent
# used by Copyright (copyright.tcl) only
proc ReturnTargetFileContent {rep} {
global homePath
set targetFile [GetTargetFile $rep]
Load $homePath/col/$rep/doc/$targetFile fileContent
return [split $fileContent \n]
}
# ReturnTargetFileContent - end
# ----------------------------------------------------------------------
# RegisterSampledDocument
proc RegisterSampledDocument {rep lastUpdate sampleC} {
global homePath
global sampledDocumentDBRepository
# docPath
set docPath $homePath/col/$sampledDocumentDBRepository/doc
set URParts [file split $rep]
set year [lindex $URParts 2]
set rest [lreplace $URParts 2 2]
regsub -all { } $rest {=} rest
regsub -all {[:/]} $lastUpdate {=} versionStamp
# directoryPath
set directoryPath $docPath/$year/$rest/$versionStamp
if [file isdirectory $directoryPath] {return} ;# security issue
file mkdir $directoryPath
set sample [binary format c* $sampleC]
Store sample $directoryPath/sample binary 1
# CREATE A NEW VERSION STAMP
set time [CreateVersionStamp [clock seconds]]
Store time $directoryPath/time
return $time
}
# RegisterSampledDocument - end
# ----------------------------------------------------------------------
# ReturnHostCollection
# returns the host collection identifier (i.e., the name of the local collection index repository)
# and the registrationPassword of the repository ($rep)
# if the calling client is the URLib server, otherwise returns empty
# used by RegisterRepositoryName only (but RegisterRepositoryName is not used)
proc ReturnHostCollection {rep} {
# runs with post
upvar addr addr
set urlibServerAddressWithIP [GetURLibServerAddress] ;# ip and port of urlib.net
# puts $urlibServerAddressWithIP ;# 150.163.34.64 800
# foreach {ip urlibPort} [ReturnCommunicationAddress $urlibServerAddressWithIP] {break} ;# commented by GJFB in 2017-12-20
foreach {ip} $urlibServerAddressWithIP {break} ;# added by GJFB in 2017-12-20 to avoid useless call to ReturnCommunicationAddress
# puts [list $addr $ip]
if [string equal $addr $ip] {
# URLib server is calling
set hostCollection [LoadHostCollection $rep]
LoadService $rep registrationPassword registrationPassword 1 1
return [list $hostCollection $registrationPassword]
}
}
# ReturnHostCollection - end
# ----------------------------------------------------------------------
# RegisterRepositoryName
# URLib server side
# returns 0 if registered
# copyright transfer protocol (from A to B) - here A and B are the identifiers of the respective collections
# 1. a repository is created in collection A (hostCollection value is A)
## 2. the repository is registered with copyright to A (A as hostCollection value + a registration password) (see RegisterRepositoryName - RegisterRepositoryName is called by RegisterRepository)
# 2. the repository is registered with copyright to A (hostCollection value is A) (see RegisterRepositoryName - RegisterRepositoryName is called by RegisterRepository)
# 3. collection B allows copyright transfer from A (see @sitesAllowedToTransferCopyright.tcl file in collection B)
# 4. A appends B to the hostCollection value (hostCollection value becomes the list {A B} - done in UpdateHostCollectionFieldValue which is called by TransferCopyright) and changes the transferable flag to zero (it must be one before the transfer beginning) (see TransferCopyright)
# 5. A restricts the doc.zip download access to B (see TransferCopyright)
## 6. A updates doc.zip (including registration password) (see TransferCopyright)
# 6. A updates doc.zip (including host collection) (see TransferCopyright)
# 7. A asks B to capture doc.zip (see TransferCopyright)
# 8. B captures the doc.zip (see CaptureRepository)
# 9. B informs A that the transfer is complete (see CaptureRepository)
# 10. A deletes the hostCollection file (see CaptureRepository)
# if A doesn't return to B the message transferable, transferNotCompleted is created in B for further tentative from the URLibService interface
# 10b. A registers the repository as B (should be done in the future - the transferable flag in B should remain zero until the new repository registration))
# 11. B turns its transferable flag to one - from now on, B could transfer its copyrights to any other local collection
# >>> RegisterRepositoryName need to be updated to include registration of copies (now a copy has an empty host collection value)
# 12. B asks to register the repository as B, displaying the hostCollection value {A B}, the old password and a new password (see CaptureRepository - CaptureRepository calls InstallRepository - InstallRepository calls RegisterRepository)
### 12. B asks to A registering the repository as B, (see CaptureRepository - CaptureRepository calls InstallRepository - InstallRepository calls RegisterRepository)
## 13. the server asks confirmation to A (A must return the new hostCollection value {A B {}} and the old registration password as registered by the server)
# 13. A ask the server to register the repository with copyright to B (hostCollection value becomes {A B})
## 14. the server checks the old registration password displayed by B, it must agree with the old registration password registered by the server (see RegisterRepositoryName)
## 15. the repository is registered (again) but now with the list {A B} as value of hostCollection and with the new registration password displayed by B (see RegisterRepositoryName)
# not in use
# >>> RegisterRepositoryName need to be updated to include registration of copies (now a copy has an empty host collection value)
proc RegisterRepositoryName {rep hostCollection registrationPassword oldRegistrationPasswordInNewHostCollection {url {}}} {
global homePath
global repositoryNameDBRepository
global loBiMiRep
# set xxx [list $rep $hostCollection $registrationPassword]
# Store xxx C:/tmp/bbb auto 0 a
# docPath
set docPath $homePath/col/$repositoryNameDBRepository/doc
set URParts [file split $rep]
set year [lindex $URParts 2]
set rest [lreplace $URParts 2 2]
regsub -all { } $rest {=} rest
# directoryPath
set directoryPath $docPath/$year/$rest ;# doc/2008/dpi.inpe.br=hermes2@80=08.22.00.00
if [file isdirectory $directoryPath] {
# repository name already registered
# check for the new host collection
Load $directoryPath/hostCollection data binary
set data [UnShift $data]
if {[lindex $data 0] != "$rep"} {return 1} ;# corrupted hostCollection
set oldHostCollection [lindex $data end]
# set xxx $oldHostCollection
# Store xxx C:/tmp/bbb auto 0 a
Load $homePath/col/$loBiMiRep/doc/@siteList.txt fileContent
set found 0
foreach line [split $fileContent \n] {
if [string equal $oldHostCollection [lindex $line 1]] {
set oldHostCollectionSite [lindex $line 0]
set found 1 ;# old host collection (A) is still registered
break
}
}
# set xxx $found
# Store xxx C:/tmp/bbb auto 0 a
if $found {
set command [list list ReturnHostCollection $rep]
# set xxx [list $oldHostCollectionSite $command]
# Store xxx C:/tmp/bbb auto 0 a
# MULTIPLE SUBMIT
set collectionPassword [MultipleExecute [list $oldHostCollectionSite] $command]
# set xxx --$collectionPassword--
# Store xxx C:/tmp/bbb auto 0 a
foreach {newHostCollection oldRegistrationPasswordInOldHostCollection} $collectionPassword {break}
if ![string equal $newHostCollection $hostCollection] {return 1} ;# inconsistency
# the site (== $hostCollection) requiring the repository registration is the one which has
# received the copyrights from the site which has transferred them
# in other words, the previoulsy registered host collection A ($oldHostCollection) is
# confirming that B ($hostCollection) is the new host collection
Load $directoryPath/password data binary
set data [UnShift $data]
if {[lindex $data 0] != "$rep"} {return 1} ;# corrupted password
set oldRegistrationPasswordInServer [lindex $data end]
if ![string equal $oldRegistrationPasswordInServer $oldRegistrationPasswordInOldHostCollection] {return 1} ;# different passwords
# the calling site A (the old host collection) knows the old registation password
if ![string equal $oldRegistrationPasswordInServer $oldRegistrationPasswordInNewHostCollection] {return 1} ;# different passwords
# the calling site B (the new host collection) knows the old registation password
} else {return 1} ;# site A not found
} else {
# new repository name to be registered
file mkdir $directoryPath
}
set data [Shift $rep $hostCollection]
Store data $directoryPath/hostCollection binary 1 ;# nonewline
set data [Shift $rep $registrationPassword]
Store data $directoryPath/password binary
return 0 ;# registration done
}
# RegisterRepositoryName - end
# ----------------------------------------------------------------------
# RegisterRepository
# client side
# used by PerformCheck, CreateRepMetadataRep, UpdateRepMetadataRep and InstallRepository (only)
# forceRegistration value is 0 or 1
# 1 means to force registration
# (set to 1 in CaptureRepository (see InstallRepository arguments)
# when called from InstallRepository, the request comes from B
# not in use
# >>> RegisterRepositoryName need to be updated to include registration of copies (now a copy has an empty host collection value)
proc RegisterRepository {rep {forceRegistration 0}} {
# runs with post
global homePath
global loCoInRep
global urlibServerAddress ;# urlib.net and port
if {[GetDocumentState $rep] && \
![TestContentType $rep Metadata] && \
[file exists $homePath/col/$rep/service/size]} {
# contains a non empty original document
if {$forceRegistration || [CheckRegistration $rep]} {
# not registered
# oldRegistrationPassword
if $forceRegistration {
if [file exists $homePath/col/$rep/service/registrationPassword] {
if [LoadService $rep registrationPassword oldRegistrationPassword 1 1] {return} ;# corrupted password
StoreService oldRegistrationPassword $rep oldRegistrationPassword 1 1 ;# because registration may fail
file delete $homePath/col/$rep/service/registrationPassword ;# to force the creation of a new password (see below)
} else {
set oldRegistrationPassword {}
}
} else {
if [file exists $homePath/col/$rep/service/oldRegistrationPassword] {
if [LoadService $rep oldRegistrationPassword oldRegistrationPassword 1 1] {return} ;# corrupted password
} else {
set oldRegistrationPassword {}
}
}
if ![file exists $homePath/col/$rep/service/registrationPassword] {
# registrationPassword file doesn't exist
# CREATE registrationPassword
regsub {0\.} [expr [SortRandomNumber]/double(233280)] {} registrationPassword
StoreService registrationPassword $rep registrationPassword 1 1
} else {
# registrationPassword file already exists
if [LoadService $rep registrationPassword registrationPassword 1 1] {return} ;# corrupted password
}
set command [list list RegisterRepositoryName $rep $loCoInRep $registrationPassword $oldRegistrationPassword]
# MULTIPLE SUBMIT
set flag [MultipleExecute [list $urlibServerAddress] $command 1]
# set xxx --$flag--
# Store xxx C:/tmp/bbb auto 0 a
if [string equal {0} $flag] {
# registered
file delete $homePath/col/$rep/service/notRegistered
file delete $homePath/col/$rep/service/oldRegistrationPassword
} else {
# not registered
set notRegistered {}
Store notRegistered $homePath/col/$rep/service/notRegistered
lappend message "RegisterRepository ([clock format [clock seconds]]):"
lappend message [CallTrace]
lappend message [list flag == --$flag--]
set log [join $message \n]
# puts $log ;# didn't work on mtc-m17.sid.inpe.br
Store log $homePath/@errorLog auto 0 a
}
}
}
}
# RegisterRepository - end
# ----------------------------------------------------------------------
# ImportRepository
# remoteSiteAddress value is the http remote site address (without http://)
# >>> the remote site is the site from which the repository will be imported
# if remoteSiteAddress is empty and repositoryName is the name of the packed repository
# in the current homePath/doc.zip then this repository is installed using this doc.zip
# repositoryName value is the name of the repository to be imported
# returns empty when the importation is made, othewise returns a non-empty error message
# administratorCodedPassword value is the administrator coded password of the site requiring importation
# startApacheServer value is 0 or 1; 1 (default) means to restart the Apache server
# Apache needs to be restarted when the repository contains a CGI script.
# If ImportRepository is called remotly under Unix, then Apache must be restarted outside
# ImportRepository (using the value 0 for startApacheServer) otherwise Submit called
# indirectly inside ImportRepository doesn't return.
# used only in CaptureRepository, SynchronizeRepository and Script (in repository: dpi.inpe.br/banon-pc@1905/2005/02.19.00.40)
# deletes download/doc.zip whenever the state value contains the word Modified (see ComputeVersionState)
proc ImportRepository {remoteSiteAddress repositoryName administratorCodedPassword {startApacheServer 1}} {
# runs with post
global homePath
global loCoInRep
global serveraddr
set message [CheckAdministratorPassword administrator $administratorCodedPassword]
if ![string equal {} $message] {return $message} ;# unfair call - don't import
if ![string equal {} $remoteSiteAddress] {
set remoteServerAddress [GetServerAddressFromHTTPHost $remoteSiteAddress]
# versionState
# set versionState [Execute $remoteSiteAddress [list ComputeVersionState $repositoryName {} 1]] ;# returns empty (unless doing frame reload) communicating from banon-pc3 to plutao
# set versionState [Execute $remoteSiteAddress [list ComputeVersionState $repositoryName {} 1] 0] ;# not async - commented by GJFB in 2015-12-01 - doesn't work with virtual host
set versionState [Execute $remoteServerAddress [list ComputeVersionState $repositoryName {} 1] 0] ;# not async - added by GJFB in 2015-12-01 - add the urlib port
# puts --$versionState-- ;# may contain an error message
# => {Registered Original} {banon-pc3 800} http://banon-pc3/rep-/dpi.inpe.br/banon/1999/12.15.21.29
if [string equal {} $versionState] {
return "the version state of the repository $repositoryName cannot be found"
}
foreach {versionState} $versionState {break}
# puts $versionState
array set stateTable {
{Registered Original} {Official}
{Modified Original} {Modified}
{Copy of an Original} {Copied}
{Modified Copy of an Original} {Modified}
{Unchecked} {Unchecked}
}
if 0 {
# commented by GJFB in 2021-02-21
if [string equal {Modified} $stateTable($versionState)] {
return "the last update in the repository $repositoryName must be reloaded"
}
if ![Execute $remoteServerAddress [list DownloadFileExists $repositoryName] 0] {
Execute $remoteServerAddress [list MakeDownloadFile $repositoryName 0 0 0 administrator] 0 ;# not async - added by GJFB in 2018-01-02 - useful when synchronizing (see SynchronizeRepository) or importing (see administrator page) a repository
}
} else {
# new code by GJFB in 2021-02-21
if [string equal {Modified} $stateTable($versionState)] {
return "the last update in the repository $repositoryName must be reloaded"
} else {
if [Execute $remoteServerAddress [list DownloadFileExists $repositoryName] 0] {
# doc.zip exists
set seconds [Execute $remoteServerAddress [list DownloadFileMtime $repositoryName] 0]
set fileTime [clock format $seconds -format %Y:%m.%d.%H.%M.%S -gmt 1]
set metadataRep [Execute $remoteServerAddress [list FindMetadataRep $repositoryName] 0]
SetFieldValue $remoteServerAddress $metadataRep-0 {metadatalastupdate}
if {[string compare $fileTime $metadatalastupdate] == -1} {
# fileTime < metadatalastupdate - doc.zip out-of-date
Execute $remoteServerAddress [list MakeDownloadFile $repositoryName 0 0 0 administrator] 0 ;# not async - added by GJFB in 2018-01-02 - useful when synchronizing (see SynchronizeRepository) or importing (see administrator page) a repository
}
} else {
# doc.zip doesn't exist
Execute $remoteServerAddress [list MakeDownloadFile $repositoryName 0 0 0 administrator] 0 ;# not async - added by GJFB in 2018-01-02 - useful when synchronizing (see SynchronizeRepository) or importing (see administrator page) a repository
}
}
}
if 0 {
package require http
set fileId [open $homePath/doc.zip w]
set convertedURL [ConvertURLToHexadecimal http://$remoteSiteAddress/col/$repositoryName/download/doc.zip]
if [catch {http::geturl $convertedURL -channel $fileId} token] {
close $fileId
# Store token C:/tmp/bbb auto 0 a
file delete $homePath/doc.zip
return "token = $token" ;# don't import
} else {
close $fileId
# upvar #0 $token state
set ncode [::http::ncode $token]
# if ![string equal {HTTP/1.1 200 OK} $state(http)] #
if ![string equal {200} $ncode] {
# for example 404: HTTP/1.1 404 Not Found
# for example 401: HTTP/1.1 401 Authorization Required
file delete $homePath/doc.zip
if [string equal {401} $ncode] {
return "col/$repositoryName/download/doc.zip at $remoteSiteAddress doesn't have the 'allow from all' permission" ;# don't import
}
# set httpState $state(http)
set code [::http::code $token]
::http::cleanup $token ;# free memory including the array state
return "state(http) = $code" ;# don't import
}
http::cleanup $token
}
} else {
# new code by GJFB in 2015-08-25
set message [StoreURLContent http://$remoteSiteAddress/col/$repositoryName/download/doc.zip doc.zip]
if ![string equal {} $message] {return $message} ;# don't import
}
}
# INSTALL
# set command [InstallRepository 0 1 0 0 1]
# set command [InstallRepository 0 1 1 0 0 $repositoryName $administratorCodedPassword] ;# Apache needs to be restarted when the repository contains a CGI script
set command [InstallRepository 0 1 $startApacheServer 0 0 $repositoryName $administratorCodedPassword] ;# added by GJFB in 2013-12-02 in order to be able to postpone Apache server restarting in col/dpi.inpe.br/banon-pc@1905/2005/02.19.00.40/doc/cgi/script.tcl (see Import repository)
if [string equal {} $command] {
# installation made
# Append repNames to the repositoryListForStart file content
# (used to update keyRepositoryList in SetIndicator)
Load ../auxdoc/repositoryList repositoryList
set repNames [join $repositoryList \n]
Store repNames ../auxdoc/repositoryListForStart auto 0 a
# Append repNames to the repositoryListForStart file content - end
} elseif {[regexp {there is an original document} $command]} {
# already manually captured
return "there is an original document" ;# don't import
} else {
# unexpected repository
return "$command" ;# unexpected repository - don't import
}
}
# ImportRepository - end
# ----------------------------------------------------------------------
# CaptureRepository
# used by PerformCheck and Dialog (Host Collection option)
# return 0 if doc.zip has been captured and an error message otherwise
# >>> runs in the new host collection (B)
# remoteSiteStamp is of the old host collection (which are transferring the copyrights) (A)
# remoteVersionStamp is of the old host collection (which are transferring the copyrights) (A)
# Capture is allowed in accordance with the permissions contained in the file
# @sitesHavingReadPermission.txt
# registrationPassword is the repository registration password (stored in service)
proc CaptureRepository {rep metadataRep remoteSiteStamp registrationPassword remoteVersionStamp} {
# runs with post
global homePath
global loCoInRep
if [file isdirectory $homePath/col/$metadataRep] {
set versionStamp [GetVersionStamp $metadataRep]
if [string equal $remoteVersionStamp $versionStamp] {
# the repository has already be captured
return 0
}
}
# Test if the remote site (A) is allowed to transfer copyright
# redundant code (already tested in Dialog by the host which is transferring the copyright)
set remoteServerAddress [lindex $remoteSiteStamp 0]
# remoteSite
set remoteSite [ReturnHTTPHost $remoteServerAddress]
# remoteHostCollection
set remoteHostCollection [lindex $remoteSiteStamp 1] ;# (A)
# remoteIp
set remoteIp [lindex $remoteSiteStamp 2]
# remoteServerAddressWithIP
foreach {m remoteURLibPort} [ReturnCommunicationAddress $remoteServerAddress] {break}
set remoteServerAddressWithIP [list $remoteIp $remoteURLibPort] ;# server address of the old host collection, ex.: {150.163.2.174 19050}
if [file exists $homePath/col/$loCoInRep/doc/@sitesAllowedToTransferCopyright.tcl] {
source $homePath/col/$loCoInRep/doc/@sitesAllowedToTransferCopyright.tcl
foreach name [array names allowedSitesArray $remoteHostCollection,*] {
regsub {.*,} $name {} name2 ;# ex: docpermission
set allowedSitesArray2($name2) $allowedSitesArray($name)
}
if ![info exists allowedSitesArray2] {return "CaptureRepository: the host collection $remoteHostCollection (A) is not allowed to transfer copyright to the host collection $loCoInRep (B)"}
} else {
return "CaptureRepository: file $homePath/col/$loCoInRep/doc/@sitesAllowedToTransferCopyright.tcl not found"
}
# Test if the remote site (A) is allowed to transfer copyright - end
# the remote site (A) is allowed to transfer copyright to the current site (B)
# i.e., B accepts documents from A
# Waiting for the completion of other repository insertions
WaitQueue
# Waiting for the completion of other repository insertions - end
# IMPORT
# administratorCodedPassword
Load $homePath/col/$loCoInRep/auxdoc/xxx data binary
set data [UnShift $data]
set administratorCodedPassword [lindex $data end]
set command [ImportRepository $remoteSite $rep $administratorCodedPassword]
if [string equal {} $command] {
# importation made
# Process Permission
set allowedSitesList2 [array get allowedSitesArray2]
ProcessPermission $allowedSitesList2 $rep $metadataRep
# Process Permission - end
LeaveQueue
set transferableFlag 0 ;# must remain 0 in A
# Delete the remote host collection field (in A)
# SUBMIT
set message [Execute $remoteServerAddressWithIP [list UpdateHostCollectionFieldValue $rep $registrationPassword {} $transferableFlag]]
# set message [Execute $remoteServerAddressWithIP [list UpdateHostCollectionFieldValue $rep $registrationPassword {} $transferableFlag] 0] ;# not async
# Delete the remote host collection field - end
if [string equal {transferable} $message] {
# copyright can now be transferred again if necessary
set transferableFlag 1 ;# end of transfer; must be 1 in B
StoreService transferableFlag $rep transferableFlag 1 1
set metadataList {}
set metadata2List {}
UpdateMetadataField $metadataRep transferableflag $transferableFlag metadataList metadata2List 1
# AddMetadata $metadataList ;# commented by GJFB in 2020-08-18
AddMetadata2 $metadataList ;# added by GJFB in 2020-08-18
} else {
Store remoteServerAddressWithIP $homePath/col/$rep/service/transferNotCompleted
}
return 0
} elseif {[regexp {there is an original document} $command]} {
# already manually captured
LeaveQueue
return 0
} else {
LeaveQueue
return "CaptureRepository: command = $command"
}
# Capture the download/doc.zip which is in A - end
}
# CaptureRepository - end
# ----------------------------------------------------------------------
# CheckRegistration
# used twice by ControlBCButtonState
# return 0 while the registration process is turned off
## return 0 if the repository has been registered or
## need not be registered (because it contains an empty document or
## there is no domain name) and
## 1 otherwise
proc CheckRegistration {rep} {
global homePath
global environmentArray
return 0 ;# returns 0 while the registration process is turned off - RegisterRepositoryName need to be updated to include registration of copies (now a copy has an empty host collection value)
# return [expr ([file exists $homePath/col/$rep/service/notRegistered] || \
![file exists $homePath/col/$rep/service/registrationPassword]) && \
[file exists $homePath/col/$rep/service/size] && \
![string equal {} $environmentArray(domainName)]]
}
# CheckRegistration - end
# ----------------------------------------------------------------------
# UpdateHostCollectionFieldValue
# security issue
# used by TransferCopyright and cgi/script (in dpi.inpe.br/banon-pc@1905/2005/02.19.00.40)
# registrationPassword is the repository registration password (stored in service)
# newHostCollection is appended to the current hostCollection
# if newHostCollection is empty then service/hostCollection file is deleted (used in CaptureRepository)
# transferableFlag value is 0 or 1
# updates hostCollection value in service/hostCollection and repositoryProperties
proc UpdateHostCollectionFieldValue {rep registrationPassword newHostCollection transferableFlag} {
# runs with post
global homePath
# registrationPassword
if [LoadService $rep registrationPassword currentRegistrationPassword 1 1] {
# corrupted password
set log "UpdateHostCollectionFieldValue: $rep has a corrupted registration password"
puts $log
Store log $homePath/@errorLog auto 0 a
return $log
}
if ![string equal $registrationPassword $currentRegistrationPassword] {
# wrong registration password
set log "UpdateHostCollectionFieldValue: $rep has a wrong registration password"
puts $log
Store log $homePath/@errorLog auto 0 a
return $log
}
if ![file isdirectory $homePath/col/$rep] {return {transferable}} ;# the repository may have been deleted after a transfer - nothing to do
if [string equal {} $newHostCollection] {
file delete $homePath/col/$rep/service/hostCollection
# file delete $homePath/col/$rep/service/transferableFlag
} else {
# CONCAT
set hostCollection [LoadHostCollection $rep]
if [string equal $newHostCollection [lindex $hostCollection end]] {
set hostCollection2 $hostCollection ;# already updated (might occur after an error)
} else {
set hostCollection2 [concat $hostCollection $newHostCollection]
}
StoreHostCollection $rep $hostCollection2
StoreService transferableFlag $rep transferableFlag 1 1
}
UpdateRepositoryProperties $rep hostcollection
# metadataRep
set metadataRep [FindMetadataRep $rep]
# Update the hostcollection of the related metadata repositories
set metadataRepList [FindAllLanguageVersions $metadataRep]
foreach mRep $metadataRepList {
if [string equal {} $newHostCollection] {
file delete $homePath/col/$mRep/service/hostCollection
} else {
StoreHostCollection $mRep $hostCollection2
}
UpdateRepositoryProperties $mRep hostcollection
}
# Update the hostcollection of the related metadata repositories - end
if {$metadataRep != {}} {
set metadataList {}
set metadata2List {}
UpdateField $rep $metadataRep hostcollection metadataList metadata2List
UpdateMetadataField $metadataRep transferableflag $transferableFlag metadataList metadata2List 1
if 0 {
# commented by GJFB in 2020-08-18
RemoveMetadata $metadata2List
AddMetadata $metadataList
} else {
UpdateMetadata $metadata2List $metadataList ;# added by GJFB in 2020-08-18 - uses metadata2List and metadataList
}
}
UpdateRepositoryListForPost [concat $rep $metadataRepList]
return {transferable}
}
# UpdateHostCollectionFieldValue - end
# ----------------------------------------------------------------------
# UpdateOAIRepositoryData
# used in StartService and SPOK
proc UpdateOAIRepositoryData {} {
global OAIProtocolRepository
global loCoInRep
global homePath
# global OAISetSpecification ;# set here and used in CreateBriefEntry
# global referenceTypeList
# set serverAddress [GetServerAddress]
if [file isdirectory $homePath/col/$OAIProtocolRepository] {
# Migration 07/12/2003
if [file isdirectory $homePath/col/$loCoInRep/doc/OAI-PMH] {
file delete -force $homePath/col/$loCoInRep/doc/OAI-PMH
}
# Migration 07/12/2003 - end
file mkdir $homePath/col/$OAIProtocolRepository/auxdoc
if ![file exists $homePath/col/$OAIProtocolRepository/auxdoc/repositoryName.txt] {
set oaiRepositoryName "URLib local collection $loCoInRep"
Store oaiRepositoryName $homePath/col/$OAIProtocolRepository/auxdoc/repositoryName.txt
}
## if ![file exists $homePath/col/$OAIProtocolRepository/auxdoc/setSpecification.txt] {
## set setSpecification {Conference Proceedings
##Thesis}
# set setSpecification [join $referenceTypeList \n]
# Store setSpecification $homePath/col/$OAIProtocolRepository/auxdoc/setSpecification.txt
## }
# Load $homePath/col/$OAIProtocolRepository/auxdoc/setSpecification.txt OAISetSpecification
# set OAISetSpecification [split $OAISetSpecification \n]
# Migration 13/03/05
file delete $homePath/col/$OAIProtocolRepository/auxdoc/setSpecification.txt
# Migration 13/03/05
if ![file exists $homePath/col/$OAIProtocolRepository/auxdoc/siteList.txt] {
set siteList ""
Store siteList $homePath/col/$OAIProtocolRepository/auxdoc/siteList.txt
}
}
}
# UpdateOAIRepositoryData - end
# ----------------------------------------------------------------------
# StoreReadPermission
# used in Dialog, UpdateRepMetadataRep and CreateRepMetadataRep
# upperSuffix value is Permission or RemotePermission
# lowerSuffix value is permission or remotepermission
# title value is Permission or Remote Permission
# argument -> service -> repositoryProperties -> metadataList
# argument -> doc
proc StoreReadPermission {
xxDefaultPermissionName xxDocAccessPermissionName xxDownloadAccessPermissionName
rep metadataRep upperSuffix lowerSuffix secure title metadataListName metadata2ListName
} {
# runs with post and start
global homePath
upvar $xxDefaultPermissionName xxDefaultPermission
upvar $xxDocAccessPermissionName xxDocAccessPermission
upvar $xxDownloadAccessPermissionName xxDownloadAccessPermission
upvar $metadataListName metadataList
upvar $metadata2ListName metadata2List
# puts [CallTrace]
# puts --$xxDocAccessPermission--
# set startApacheServer 0
if $xxDefaultPermission {
file delete $homePath/col/$rep/service/doc$upperSuffix
if [Info exists repositoryProperties($rep,doc$lowerSuffix)] {
Unset repositoryProperties($rep,doc$lowerSuffix)
# set startApacheServer [expr !$secure]
}
file delete $homePath/col/$rep/service/download$upperSuffix
if [Info exists repositoryProperties($rep,download$lowerSuffix)] {
Unset repositoryProperties($rep,download$lowerSuffix)
# set startApacheServer [expr !$secure]
}
if [string equal {Permission} $title] {
if {$metadataRep != {}} {
DeleteMetadataField $metadataRep readpermission \
metadata2List 1
}
}
} else {
# Convert to one host per line
set xxDocAccessPermission [Convert2OneHostPerLine $xxDocAccessPermission]
# Convert to one host per line - end
LoadService $rep doc$upperSuffix oldXXDocAccessPermission $secure 1
StoreService xxDocAccessPermission $rep doc$upperSuffix $secure 1
if {$oldXXDocAccessPermission == {} || \
$oldXXDocAccessPermission != "$xxDocAccessPermission"} {
Eval UpdateRepositoryProperties $rep doc$lowerSuffix
# set startApacheServer [expr !$secure]
}
# Convert to one host per line
set xxDownloadAccessPermission [Convert2OneHostPerLine $xxDownloadAccessPermission]
# Convert to one host per line - end
LoadService $rep download$upperSuffix oldXXDownloadAccessPermission $secure 1
StoreService xxDownloadAccessPermission $rep download$upperSuffix $secure 1
if {$oldXXDownloadAccessPermission == {} || \
$oldXXDownloadAccessPermission != "$xxDownloadAccessPermission"} {
Eval UpdateRepositoryProperties $rep download$lowerSuffix
# set startApacheServer [expr !$secure]
}
if [string equal {Permission} $title] {
if {$metadataRep != {}} {
set xxDocAccessPermission2 [string trim $xxDocAccessPermission \n] ;# added by GJFB in 2011-04-10
regsub -all "\n" $xxDocAccessPermission2 { and } value
UpdateMetadataField $metadataRep readpermission $value metadataList metadata2List 1
}
}
}
# return $startApacheServer
return 0 ;# because of the access file use
}
# StoreReadPermission - end
# ----------------------------------------------------------------------
# UpdateAccessFile
# creates, updates or deletes the .htaccess file
# called in ProcessPermission, SetAdvancedUserFromUserGroup, UpdateRepMetadataRep and InstallRepository
# UpdateAccessFile calls ComputeAccess
# ComputeAccess uses repositoryProperties array
# when running InstallRepository
# repositoryProperties array is updated in UpdateRepositoryProperties called in UpdateCollection called in InstallRepository
proc UpdateAccessFile {rep} {
# runs with post and start
global homePath
global environmentArray
# global applicationName
global loCoInRep
# administratorUserName
regsub {@.*$} $environmentArray(spMailEntry) {} administratorUserName
# ipAddress
set ipAddress $environmentArray(ipAddress)
# compute default access
foreach {defaultAuthenticationFlag spDocAccessPermission spDownloadAccessPermission directivesForCGI} [ComputeDefaultAccess $ipAddress 1] {break}
# compute access
foreach {authDirectives docPermission downloadPermission} [Eval ComputeAccess $rep $administratorUserName $defaultAuthenticationFlag $spDocAccessPermission $spDownloadAccessPermission $ipAddress 1] {break}
# puts $rep
# puts [list $authDirectives $docPermission $downloadPermission]
# doc
if {![string equal {} $docPermission] || ![string equal {} $authDirectives]} {
set fileContent "Satisfy any$docPermission$authDirectives"
if [file isdirectory $homePath/col/$rep/doc] {
Store fileContent $homePath/col/$rep/doc/.htaccess
}
} else {
file delete $homePath/col/$rep/doc/.htaccess
}
# Updating .htaccess and .htaccess2 when the target file is a UTF-8 html file
# added by GJFB and GPRB in 2025-06-16
Load $homePath/col/$rep/service/targetFile targetFileName
# puts $targetFileName
if [regexp {.htm} $targetFileName] {
Load $homePath/col/$rep/doc/$targetFileName targetFileContent
# puts [regexp {< *meta +charset *= *" *UTF-8.*".*>} $targetFileContent]
if [regexp {< *meta +charset *= *" *UTF-8.*".*>} $targetFileContent] {
set directive {AddDefaultCharset UTF-8}
Store directive $homePath/col/$rep/doc/.htaccess auto 0 a
Store directive $homePath/col/$rep/doc/.htaccess2 auto 0 a
}
}
# Updating .htaccess and .htaccess2 when the target file is a UTF-8 html file - end
if ![string equal {} $docPermission] {
set fileContent $docPermission
if [file isdirectory $homePath/col/$rep/doc] {
Store fileContent $homePath/col/$rep/doc/.htaccess2
}
} else {
file delete $homePath/col/$rep/doc/.htaccess2
}
# download
if {![string equal {} $downloadPermission] || ![string equal {} $authDirectives]} {
set fileContent "Satisfy any$downloadPermission$authDirectives"
file mkdir $homePath/col/$rep/download
Store fileContent $homePath/col/$rep/download/.htaccess
} else {
file delete $homePath/col/$rep/download/.htaccess
}
if ![string equal {} $downloadPermission] {
set fileContent $downloadPermission
file mkdir $homePath/col/$rep/download
Store fileContent $homePath/col/$rep/download/.htaccess2
} else {
file delete $homePath/col/$rep/download/.htaccess2
}
# Restrict access to update and review
if 0 {
if {$applicationName == "post"} {
# Info doesn't work when UpdateAccessFile is called from a cgi script (Get or Get-) (with mtc-m19)
global repositoryProperties
set flag [info exists repositoryProperties($rep,username)]
} else {
set flag [Info exists repositoryProperties($rep,username)]
}
} else {
# if is now in Info
set flag [Info exists repositoryProperties($rep,username)]
}
if $flag {
file mkdir $homePath/col/$rep/auxdoc/cgi2
set fileContent \
"
allow from all
"
Store fileContent $homePath/col/$rep/auxdoc/cgi2/.htaccess
set fileContent \
"
allow from all
"
Store fileContent $homePath/col/$rep/auxdoc/cgi2/.htaccess2
} else {
file delete $homePath/col/$rep/auxdoc/cgi2/.htaccess
file delete $homePath/col/$rep/auxdoc/cgi2/.htaccess2
}
if [file exists $homePath/col/$rep/auxdoc/cgi3/review] {
if {![string equal {} $authDirectives] && !$defaultAuthenticationFlag} {
set fileContent \
"
AuthName \"URLib Update Form\"
AuthType Basic
AuthUserFile \"$homePath/col/$loCoInRep/auxdoc/@passwords.txt\"$authDirectives
satisfy any
"
Store fileContent $homePath/col/$rep/auxdoc/cgi3/.htaccess
} else {
# don't display review
file delete $homePath/col/$rep/auxdoc/cgi3/.htaccess
}
}
# Restrict access to update and review - end
}
# UpdateAccessFile - end
# ----------------------------------------------------------------------
# SetAccessPermission
# used in UpdateRepMetadataRep and CreateRepMetadataRep
# doesn't change xxDefaultPermission
# content equivalence for readPermission: ip <==> deny from all and allow from ip
proc SetAccessPermission {
rep readPermission xxDefaultPermissionName
xxDocAccessPermissionName xxDownloadAccessPermissionName
} {
# runs with post and start
global repositoryProperties ;# used when UpdateRepMetadataRep is calling
upvar $xxDefaultPermissionName xxDefaultPermission
upvar $xxDocAccessPermissionName xxDocAccessPermission
upvar $xxDownloadAccessPermissionName xxDownloadAccessPermission
# puts --$readPermission--
if $xxDefaultPermission {
set xxDocAccessPermission {} ;# used in CreateRepMetadataRep - added by GJFB in 2011-06-13 to avoid: can't read "xxDocAccessPermission": no such variable while executing "regexp {deny} $xxDocAccessPermission"
} else {
if [regexp {from} $readPermission] {
regsub -all { and } $readPermission "\n" xxDocAccessPermission
} else {
if [string equal {intranet} $readPermission] {
# runs with post only
# metadataRep
set metadataRep [FindMetadataRep $rep]
# year
set year [GetFieldValue $metadataRep-0 year]
# group
set group [GetFieldValue $metadataRep-0 group]
# ipList
# puts "[list ReturnIntranetConfiguration $year $group]"
if [catch {ReturnIntranetConfiguration $year $group} ipList] {
set xxDocAccessPermission "deny from all"
} else {
if [string equal {} $ipList] {
set xxDocAccessPermission "deny from all"
} else {
set xxDocAccessPermission "deny from all
allow from $ipList"
}
}
} else {
set xxDocAccessPermission "deny from all
allow from $readPermission"
}
}
if [info exists repositoryProperties($rep,downloadpermission)] {
set xxDownloadAccessPermission $repositoryProperties($rep,downloadpermission)
} else {
set xxDownloadAccessPermission "deny from all"
}
if [regexp {^ *deny +from +all *$} $xxDocAccessPermission] {
set xxDownloadAccessPermission "deny from all"
} elseif ![regexp {^ *allow +from +all *$} $xxDocAccessPermission] {
# there are some restrictions
if ![regexp {^ *deny +from +all *$} $xxDownloadAccessPermission] {
set xxDownloadAccessPermission $xxDocAccessPermission
}
}
}
}
# SetAccessPermission - end
# ----------------------------------------------------------------------
# UpdateRepositoryListForPost
# repositoryListForPost contains the list of repositories
# that have been created, updated or deleted during the
# current posting
proc UpdateRepositoryListForPost {repList} {
# runs with post
global repositoryListForPost
global repositoryListForStart
global saveMetadata
if ![info exists repositoryListForPost] {set repositoryListForPost {}}
set repositoryListForPost [concat $repositoryListForPost $repList]
set repositoryListForPost [lsort -unique $repositoryListForPost]
if {[llength $repositoryListForPost] > 200} {
# to speed up the next repository creations
SaveRepositoryProperties 1
SaveReferenceTable 1
set saveMetadata 1
SaveMetadata 1
set repositoryListForStart {}
if [file exists ../auxdoc/.repositoryListForStart.tcl] {
source ../auxdoc/.repositoryListForStart.tcl ;# set the variable repositoryListForStart
}
set repositoryListForStart [concat $repositoryListForPost $repositoryListForStart]
set repositoryListForStart [lsort -unique $repositoryListForStart]
StoreList repositoryListForStart ../auxdoc/.repositoryListForStart.tcl
file delete ../auxdoc/.repositoryListForPost.tcl
unset repositoryListForPost
} else {
StoreList repositoryListForPost ../auxdoc/.repositoryListForPost.tcl
}
# set xxx [CallTrace]
# Store xxx C:/tmp/bbb auto 0 a
}
if 0 {
source utilitiesStart.tcl
UpdateRepositoryListForPost dpi.inpe.br/banon/1998/08.02.08.56
}
# UpdateRepositoryListForPost - end
# ----------------------------------------------------------------------
# TransferCopyright
# >>> runs in the old host collection (A)
# transferts copyright from A to B
# if the information item doesn't exist as a copy in B it is created
# used by Dialog
# rep value is the name of the repository to be transferred
# remoteSiteStamp value is the stamp of the site receiving the copyright (B)
# save value is 0 or 1,
# 1 means to update and save the metadata
# example of @sitesAllowedToTransferCopyright.tcl content (in B - allowedSitesArray contains the sites allowed/accepted to transfert copyright, A must be such a site):
if 0 {
array set allowedSitesArray {
bighost.com.br/banon/2005/05.04.18.04,defaultpermission {0}
bighost.com.br/banon/2005/05.04.18.04,docpermission {{allow from all}}
bighost.com.br/banon/2005/05.04.18.04,downloadpermission {{deny from all} {allow from 127.0.0.1} {allow from 192.168.1.100} {allow from 150.163}}
bighost.com.br/banon/2005/05.04.18.04,mirrorsites {bighost.com.br/banon/2005/05.04.18.04}
bighost.com.br/banon/2005/05.04.18.04,defaultremotepermission {0}
bighost.com.br/banon/2005/05.04.18.04,docremotepermission {{allow from all}}
bighost.com.br/banon/2005/05.04.18.04,downloadremotepermission {{deny from all}}
}
array set allowedSitesArray {
dpi.inpe.br/banon/2001/02.23.19.23,defaultpermission {0}
dpi.inpe.br/banon/2001/02.23.19.23,docpermission {{allow from all}}
dpi.inpe.br/banon/2001/02.23.19.23,downloadpermission {{allow from all}}
dpi.inpe.br/banon/2001/02.23.19.23,mirrorsites {dpi.inpe.br/banon/2001/02.23.19.23}
dpi.inpe.br/banon/2001/02.23.19.23,defaultremotepermission {0}
dpi.inpe.br/banon/2001/02.23.19.23,docremotepermission {{allow from all}}
dpi.inpe.br/banon/2001/02.23.19.23,downloadremotepermission {{deny from all}}
}
}
# The pairs in allowedSitesArray define how (B) decides about the repository permissions in (A) once the transfert was completed
# In the above exemple, (B) decides that the site bighost.com.br/banon/2005/05.04.18.04 (A) becomes a mirror site (~ mirror archive) for the repository whose copyright has been transferred to (B)
# The allowed sites must be in accordance with the permissions contained in the file
# @sitesHavingReadPermission.txt (otherwise CaptureRepository is not executed), that is, allowed sites must be client sites having read permission, A must be such a site
# username must be administrator or the administrator name
# The administrator must have been registered as an advanced user (otherwise CaptureRepository is not executed)
proc TransferCopyright {rep metadataRep remoteSiteStamp userName} {
# runs with post
global homePath
global URLibServiceRepository
global repositoryProperties
global environmentArray
global startApacheServer
global tcl_platform
# administratorUserName
regsub {@.*$} $environmentArray(spMailEntry) {} administratorUserName
if ![string equal administrator $userName] {
if [string equal $administratorUserName $userName] {
# $userName is the administrator
} else {
# $userName is not the administrator
return "TransferCopyright (1): '$userName' is not the administrator"
}
}
set metadataList {}
set metadata2List {}
# remoteHostCollection (B)
set remoteHostCollection [lindex $remoteSiteStamp 1]
if 0 {
if ![GetDocumentState $rep 1] {
# don't transfer - the repository doesn't contain the original document
return {TransferCopyright: the repository doesn't contain the original document}
}
}
if ![file exists $homePath/col/$rep/service/notCaptured] {
if [string equal $repositoryProperties($rep,hostcollection) $remoteHostCollection] {
# don't transfer - the remote host collection is the current one
return {the remote host collection is the current one}
}
}
# Capure @sitesAllowedToTransferCopyright.tcl (in B)
# remoteServerAddress
set remoteServerAddress [lindex $remoteSiteStamp 0] ;# server address of the new host collection (B)
# remoteSite
set remoteSite [ReturnHTTPHost $remoteServerAddress] ;# (B)
# remoteIp
set remoteIp [lindex $remoteSiteStamp 2] ;# (B)
# siteStamp (A)
set siteStamp [lrange [GetSiteStamp] 0 2]
# Store siteStamp C:/tmp/bbb auto 0 a
# localHostCollection (A)
set localHostCollection [lindex $siteStamp 1] ;# == loCoInRep
# set xxx http://$remoteSite/col/$remoteHostCollection/doc/%40sitesAllowedToTransferCopyright.tcl
# Store xxx C:/tmp/bbb auto 0 a
set convertedURL [ConvertURLToHexadecimal http://$remoteSite/col/$remoteHostCollection/doc/@sitesAllowedToTransferCopyright.tcl]
if [catch {http::geturl $convertedURL} token] {
# don't transfer - unknown host collection
# global errorInfo
# return "$token $errorInfo"
return {unknown host}
} else {
upvar #0 $token state
if ![string equal {HTTP/1.1 200 OK} $state(http)] {
# for example: HTTP/1.1 404 Not Found
http::cleanup $token
return {@sitesAllowedToTransferCopyright.tcl not found or permission denied}
}
# the file exists in the remoteSite and can be reached (there no access restriction)
eval [http::data $token] ;# creates allowedSitesArray
http::cleanup $token
}
# allowedSitesArray2
foreach name [array names allowedSitesArray $localHostCollection,*] {
regsub {.*,} $name {} name2 ;# ex: docpermission - used in ProcessPermission
set allowedSitesArray2($name2) $allowedSitesArray($name)
}
# Capure @sitesAllowedToTransferCopyright.tcl - end
if ![info exists allowedSitesArray2] {return {site not allowed to transfer copyright}} ;# (A) is not allowed to transfert copyright to (B)
TestUpdateLastUpdate $rep $metadataRep 0 $administratorUserName ;# must be before the host collection change below
# registrationPassword
if ![file exists $homePath/col/$rep/service/registrationPassword] {
# registrationPassword file doesn't exist
# CREATE registrationPassword
regsub {0\.} [expr [SortRandomNumber]/double(233280)] {} registrationPassword
StoreService registrationPassword $rep registrationPassword 1 1
} else {
# registrationPassword file already exists
if [LoadService $rep registrationPassword registrationPassword 1 1] {
# corrupted password
return "$rep has a corrupted registration password"
}
}
# Update the host collection field value
# A -> A B
set transferableFlag 0 ;# beginning of transfer ; must remain 0 in A for ever and 0 in B as long as the transfer is not completed
# UpdateHostCollectionFieldValue $rep $metadataRep $registrationPassword $remoteHostCollection $transferableFlag
UpdateHostCollectionFieldValue $rep $registrationPassword $remoteHostCollection $transferableFlag ;# updates hostCollection value in service/hostCollection and repositoryProperties
# Update the host collection field value - end
# localIp
set localIp $environmentArray(ipAddress)
# Update permissions
# Process Mirror Sites
if [file exists $homePath/col/$rep/service/mirrorSites] {
file delete $homePath/col/$rep/service/mirrorSites
UpdateRepositoryProperties $rep mirrorsites
if [file exists $homePath/col/$rep/download/doc.zip] {
# doc.zip must exist, otherwise zip returns: zip warning: name not matched: col/iconet.com.br/banon/2003/03.31.16.30/service/mirrorSites
set message [UpdateArchiveFile $rep col/$rep/service/mirrorSites -d]
if ![string equal {} $message] {return "TransferCopyright (2): $message"}
}
}
# Process Mirror Sites - end
# Process Remote Permission
set remotePermission [join [list {deny from all} "allow from $remoteIp" "allow from $localIp"] \n]
LoadService $rep docRemotePermission oldRemotePermission 1 1
if ![string equal $remotePermission $oldRemotePermission] {
StoreService remotePermission $rep docRemotePermission 1 1
UpdateRepositoryProperties $rep docremotepermission
}
LoadService $rep downloadRemotePermission oldRemotePermission 1 1
if ![string equal $remotePermission $oldRemotePermission] {
StoreService remotePermission $rep downloadRemotePermission 1 1
UpdateRepositoryProperties $rep downloadremotepermission
}
# set xxx $repositoryProperties($rep,downloadremotepermission)
# Store xxx C:/tmp/bbb auto 0 a
SaveRepositoryProperties
# Process Remote Permission - end
# set startApacheServer 1
# StartApacheServer ;# doesn't work with solaris - the remote call to the procedure TransferCopyright doesn't finish
if {$tcl_platform(platform) == "unix"} {
# not tested
# if [file owned $homePath/col/$rep/download] {exec chmod 775 $homePath/col/$rep/download}
}
Store remotePermission $homePath/col/$rep/download/.htaccess
# Update permissions - end
## Migration 3/3/03
# file delete $homePath/col/$rep/service/password
## Migration 3/3/03 - end
# Delete userName
if [file exists $homePath/col/$rep/service/userName] {
set userName $repositoryProperties($rep,username)
file delete $homePath/col/$rep/service/userName
UpdateRepositoryProperties $rep username
if [file exists $homePath/col/$rep/download/doc.zip] {
# doc.zip must exist, otherwise zip returns: zip warning: name not matched: col/iconet.com.br/banon/2003/03.31.16.30/service/userName
if [string equal {administrator} $userName] {
# userName is in doc.zip if and only if user name is administrator (see MakeDownloadFile)
set message [UpdateArchiveFile $rep col/$rep/service/userName -d]
if ![string equal {} $message] {return "TransferCopyright (3): $message"}
}
}
}
# Delete userName - end
# Update download files
# UpdateDownloadFilesByAdministrator $rep 1
if ![file exists $homePath/col/$rep/download/doc.zip] {
UpdateDownloadFilesByAdministrator $rep ;# pack doc
}
UpdateDownloadFilesByAdministrator $rep 2 ;# pack everything except doc
# add hostCollection and transferableFlag
if [file exists $homePath/col/$rep/service/hostCollection] {
set message [UpdateArchiveFile $rep [list col/$rep/service/hostCollection col/$rep/service/transferableFlag]]
if ![string equal {} $message] {return "TransferCopyright (4): $message"}
}
set metadataRepList [FindAllLanguageVersions $metadataRep]
foreach mRep $metadataRepList {
if [file exists $homePath/col/$mRep/service/hostCollection] {
set message [UpdateArchiveFile $rep col/$mRep/service/hostCollection]
if ![string equal {} $message] {return "TransferCopyright (5): $message"}
}
}
# Update download files - end
# Ask to capture the repository in this local collection
# (A) asks (B) to capture the repository in (A)
# regexp {:(.*)} $remoteSite m serverPort
# set remoteHostCollectionServerAddress $remoteIp:$serverPort ;# server address of the new host collection, ex.: 150.163.8.245:1905
# Store remoteHostCollectionServerAddress $homePath/col/$rep/service/notRemotelyRegistered
# Store remoteServerAddress $homePath/col/$rep/service/notRemotelyRegistered
foreach {m remoteURLibPort} [ReturnCommunicationAddress $remoteServerAddress] {break}
set remoteServerAddressWithIP [list $remoteIp $remoteURLibPort] ;# server address of the new host collection, ex.: {150.163.2.174 19050}
if [file exists $homePath/col/$rep/service/notCaptured] {
# a copyright transfer may have been done but (A) receives a premature return of CaptureRepository
# because the transfer lasts longer than the MultipleExecute time-out
set versionStamp [GetVersionStamp $metadataRep]
} else {
set versionStamp {}
}
# MULTIPLE SUBMIT
# set command [list list CaptureRepository $rep $metadataRep $siteStamp $registrationPassword]
set command [list list CaptureRepository $rep $metadataRep $siteStamp $registrationPassword $versionStamp]
# set flag [MultipleExecute [list $remoteHostCollectionServerAddress] $command]
# set flag [MultipleExecute [list $remoteServerAddress] $command]
set flag [MultipleExecute [list $remoteServerAddressWithIP] $command]
# puts --$flag--
if [string equal {0} $flag] {
# captured
file delete $homePath/col/$rep/service/notCaptured ;# (A)
if 0 {
# Process Remote Permission
file delete $homePath/col/$rep/service/docRemotePermission
Eval UpdateRepositoryProperties $rep docremotepermission
file delete $homePath/col/$rep/service/downloadRemotePermission
Eval UpdateRepositoryProperties $rep downloadremotepermission
# Process Remote Permission - end
}
} else {
# not captured
# Store remoteHostCollectionServerAddress $homePath/col/$rep/service/notCaptured
# Store remoteServerAddress $homePath/col/$rep/service/notCaptured
# Store remoteServerAddressWithIP $homePath/col/$rep/service/notCaptured
Store remoteSiteStamp $homePath/col/$rep/service/notCaptured ;# (A)
return "TransferCopyright: --$flag--" ;# this message is interpreted in Dialog (utilities2.tcl)
}
# captured
file delete $homePath/col/$rep/download/doc.zip ;# this doc.zip is just for transferring the copyrights
file delete $homePath/col/$rep/download/.htaccess
file delete -force $homePath/col/$rep/auxdoc/cgi2 ;# may contain the update file
# Process Permission
set allowedSitesList2 [array get allowedSitesArray2]
ProcessPermission $allowedSitesList2 $rep $metadataRep
# Process Permission - end
# Ask to capture the repository in this local collection - end
# UpdateRepositoryListForPost [concat $rep $metadataRepList]
UpdateRepositoryListForPost [concat $rep $metadataRep]
# SAVE - end
}
# TransferCopyright - end
# ----------------------------------------------------------------------
# UpdateArchiveFile
# updates the download/doc.zip file within rep
# used in TransferCopyright
# fileNameList is a list of path names (beginning with col) of the files to be updated (or deleted)
# option value is empty or -d (for delete)
# example: UpdateArchiveFile iconet.com.br/banon/2003/03.31.16.30 col/iconet.com.br/banon/2003/03.31.16.30/service/mirrorSites -d
# if done, returns empty, otherwise returns an error message
proc UpdateArchiveFile {rep fileNameList {option {}}} {
global homePath
global zipPath
global pwd
cd $homePath
if [catch {eval "exec \"$zipPath\" $option \"$homePath/col/$rep/download/doc.zip\" $fileNameList"} message] {
cd $pwd
return "UpdateArchiveFile: $message"
}
cd $pwd
}
# UpdateArchiveFile - end
# ----------------------------------------------------------------------
# ProcessPermission
# used in UpdateHostCollectionFieldValue and CaptureRepository only
proc ProcessPermission {allowedSitesList2 rep metadataRep} {
# runs with post
global homePath
array set allowedSitesArray2 $allowedSitesList2
set metadataList {}
set metadata2List {}
set defaultPermission $allowedSitesArray2(defaultpermission)
set docPermission [join $allowedSitesArray2(docpermission) \n]
set downloadPermission [join $allowedSitesArray2(downloadpermission) \n]
StoreReadPermission defaultPermission docPermission downloadPermission \
$rep $metadataRep \
Permission permission 0 Permission metadataList metadata2List
set defaultRemotePermission $allowedSitesArray2(defaultremotepermission)
set docRemotePermission [join $allowedSitesArray2(docremotepermission) \n]
set downloadRemotePermission [join $allowedSitesArray2(downloadremotepermission) \n]
StoreReadPermission defaultRemotePermission docRemotePermission downloadRemotePermission \
$rep $metadataRep \
RemotePermission remotepermission 1 {Remote Permission} metadataList metadata2List
if 0 {
# commented by GJFB in 2020-08-18
RemoveMetadata $metadata2List
AddMetadata $metadataList
} else {
UpdateMetadata $metadata2List $metadataList ;# added by GJFB in 2020-08-18 - uses metadata2List and metadataList
}
# SAVE
set saveMetadata 1
SaveMetadata
# Store read permission - end
# Store mirrorSites
if ![string equal {} $allowedSitesArray2(mirrorsites)] {
if 0 {
set mirrorSites {}
foreach item $allowedSitesArray2(mirrorsites) {
lappend mirrorSites [lindex $item 1]
}
}
set mirrorSites $allowedSitesArray2(mirrorsites)
StoreService mirrorSites $rep mirrorSites 1 1
} else {
file delete $homePath/col/$rep/service/mirrorSites
}
UpdateRepositoryProperties $rep mirrorsites
SaveRepositoryProperties
# Store mirrorSites - end
UpdateAccessFile $rep
}
# ProcessPermission - end
# ----------------------------------------------------------------------
# SetAdvancedUserFromUserGroup
# set an advanced user from the user group
## and update the reader group by concatenating to it the user group
# use as advanced user name the first name
# in the usergroup field which is not administrator
# used only by the cgi script in dpi.inpe.br/banon-pc@1905/2005/02.19.00.40
# password must be coded
proc SetAdvancedUserFromUserGroup {rep userName password} {
# runs with post
global homePath
# metadataRep
set metadataRep [FindMetadataRep $rep]
# userGroup
set userGroup [GetFieldValue $metadataRep-0 usergroup]
# advancedUserName
if ![string equal {} $userGroup] {
foreach user $userGroup {
if ![string equal {administrator} $user] {break}
}
set advancedUserName $user
} else {
return "usergroup is empty"
}
## readerGroup
# set readerGroup [GetFieldValue $metadataRep-0 readergroup]
# set readerGroup [concat $readerGroup $userGroup] ;# add userGroup (useful for 8ICSHMO)
# set readerGroup [lsort -unique $readerGroup]
set return [MakeCgiScript2 $rep $userName $password]
if ![string equal {} $return] {return $return}
# remove
set metadata2List [GetMetadata $metadataRep-0,username]
# set metadata2List [concat $metadata2List [GetMetadata $metadataRep-0,readergroup]]
# add
set metadataList [list $metadataRep-0,username $advancedUserName]
# set metadataList [concat $metadataList [list $metadataRep-0,readergroup $readerGroup]]
LoadService $rep userName oldUserName 1 1
#
# doesn't append the user name to the user group (this is done in Dialog (see utilities2.tcl) not in this procedure)
#
# Update history
# CREATE A NEW VERSION STAMP (for the metadata repository (metadataRep))
set seconds [clock seconds]
if [string equal {} $oldUserName] {set oldUserName administrator}
Load $homePath/col/$metadataRep/doc/@metadata.refer referMetadata
set metadataVersionStamp [CreateVersionStamp $seconds $oldUserName $referMetadata] ;# it is assumed that the administrator acts on behalf of the old user
UpdateHistory $metadataRep $metadataVersionStamp
# Update history - end
# remove
set metadata2List [concat $metadata2List [GetMetadata $metadataRep-0,metadatalastupdate]]
# add
set metadataList [concat $metadataList [list $metadataRep-0,metadatalastupdate $metadataVersionStamp]]
StoreService advancedUserName $rep userName 1 1
# Store readerGroup $homePath/col/$rep/service/authenticatedUsers
UpdateRepositoryProperties $rep username
UpdateRepositoryProperties $rep authenticatedusers
UpdateAccessFile $rep
if 0 {
# commented by GJFB in 2020-08-18
RemoveMetadata $metadata2List
AddMetadata $metadataList
} else {
UpdateMetadata $metadata2List $metadataList ;# added by GJFB in 2020-08-18 - uses metadata2List and metadataList
}
set repositoryList $rep
lappend repositoryList $metadataRep
UpdateRepositoryListForPost $repositoryList
}
# SetAdvancedUserFromUserGroup - end
# ----------------------------------------------------------------------
# ManageLogFile
# Leaves the log file size not greater than 200000 bytes
# absolutePath is the absolute path of the log file
# the log file name must be without file type or with file type .log
# examples:
# ManageLogFile $homePath/@errorLog
# ManageLogFile $homePath/col/dpi.inpe.br/banon-pc@1905/2005/02.19.00.40/auxdoc/@actionLog - added by GJFB in 2017-11-18 - see Administrator page
# ManageLogFile $homePath/col/$URLibServiceRepository/auxdoc/serverDir/logs/access.log
# ManageLogFile $homePath/col/$URLibServiceRepository/auxdoc/serverDir/logs/error.log
proc ManageLogFile {absolutePath} {
global tcl_platform
global errorInfo
global homePath
global loCoInRep
global URLibServiceRepository
# Log migration - 2023-03-16
if [file isdirectory $homePath/col/$loCoInRep/doc/URLibServiceLog] {
if ![file isdirectory $homePath/col/$loCoInRep/auxdoc/URLibServiceLog] {
file mkdir $homePath/col/$loCoInRep/auxdoc/URLibServiceLog
set path $homePath/col/$loCoInRep/doc/URLibServiceLog/@errorLog
foreach item [glob -nocomplain $path*] {
if [regexp "^$path\\d+$" $item] {
file rename $item $homePath/col/$loCoInRep/auxdoc/URLibServiceLog/[file tail $item]
}
}
file delete $homePath/col/$loCoInRep/doc/URLibServiceLog
file delete -force $homePath/col/$loCoInRep/doc/access ;# for old collection
}
}
if [file isdirectory $homePath/col/$loCoInRep/doc/ApacheLog] {
if ![file isdirectory $homePath/col/$loCoInRep/auxdoc/ApacheLog] {
file mkdir $homePath/col/$loCoInRep/auxdoc/ApacheLog
set rootPath $homePath/col/$loCoInRep/doc/ApacheLog/access
foreach item [glob -nocomplain $rootPath*] {
if [regexp "^$rootPath\\d+\\.log$" $item] {
file rename $item $homePath/col/$loCoInRep/auxdoc/ApacheLog/[file tail $item]
}
}
set rootPath $homePath/col/$loCoInRep/doc/ApacheLog/error
foreach item [glob -nocomplain $rootPath*] {
if [regexp "^$rootPath\\d+\\.log$" $item] {
file rename $item $homePath/col/$loCoInRep/auxdoc/ApacheLog/[file tail $item]
}
}
file delete $homePath/col/$loCoInRep/doc/ApacheLog
}
}
# Log migration - 2023-03-16 - end
if ![file isdirectory $homePath/col/$loCoInRep/auxdoc/URLibServiceLog] { ;# added by GJFB in 2020-06-12 - required at installation of a new local collection
file mkdir $homePath/col/$loCoInRep/auxdoc/URLibServiceLog
}
if ![file isdirectory $homePath/col/$loCoInRep/auxdoc/ApacheLog] { ;# added by GJFB in 2020-06-12 - required at installation of a new local collection
file mkdir $homePath/col/$loCoInRep/auxdoc/ApacheLog
}
if [catch {set size [file size $absolutePath]}] {return}
if [expr $size < 200000] {return}
# if [expr $size < 2000] {return} ;# for testing
if [regexp {(.*)\.log$} $absolutePath m rootPath] {
# file type is .log
# ApacheLog
# $homePath/col/$URLibServiceRepository/auxdoc/serverDir/logs/access.log -> $homePath/col/$loCoInRep/auxdoc/ApacheLog/access
set root [file tail $rootPath] ;# access or error
set absolutePath2 $homePath/col/$loCoInRep/auxdoc/ApacheLog/$root ;# destination
set lastLogFile [lindex [lsort -dictionary [glob -nocomplain $absolutePath2*.log]] end]
# fileNumber
if [string equal {} $lastLogFile] {
set fileNumber 0
} else {
regexp "${absolutePath2}(.*).log$" $lastLogFile m fileNumber
}
incr fileNumber
if [catch {file rename $absolutePath $absolutePath2$fileNumber.log}] {
# on Windows one may get a "permission denied" while apache is running
set log "\[[clock format [clock seconds] -format %Y:%m.%d.%H.%M.%S]\] ManageLogFile: the following error has been catched:\n\"$errorInfo\"\n"
puts $log
Store log $homePath/@errorLog auto 0 a
}
} else {
# file type is not .log
# URLibServiceLog
# $homePath/@errorLog -> $homePath/col/$loCoInRep/auxdoc/URLibServiceLog/@errorLog
# set absolutePath2 $homePath/col/$loCoInRep/auxdoc/URLibServiceLog/@errorLog ;# destination - commented by GJFB in 2017-11-18
set root [file tail $absolutePath] ;# @errorLog or @actionLog - added by GJFB in 2017-11-18
set absolutePath2 $homePath/col/$loCoInRep/auxdoc/URLibServiceLog/$root ;# destination - added by GJFB in 2017-11-18
set lastLogFile [lindex [lsort -dictionary [glob -nocomplain $absolutePath2*]] end]
# fileNumber
if [string equal {} $lastLogFile] {
set fileNumber 0
} else {
regexp "${absolutePath2}(.*)$" $lastLogFile m fileNumber
}
incr fileNumber
file rename $absolutePath $absolutePath2$fileNumber
if {$tcl_platform(platform) == "unix"} {
set log {}
Store log $absolutePath
exec chmod g+w $absolutePath ;# needed by some cgi scripts writing in @errorLog
}
}
}
# ManageLogFile - end
# ----------------------------------------------------------------------
# ListIntersection
# used in Search
proc ListIntersection {list1Name list2Name} {
upvar $list1Name list1
upvar $list2Name list2
set list {}
foreach element $list1 {
if {[lsearch -exact $list2 $element] >= 0} {
lappend list $element
}
}
return $list
}
# ListIntersection - end
# ----------------------------------------------------------------------
# ListNegatedImplication
# used in Script within dpi.inpe.br/banon-pc@1905/2005/02.19.00.40 (administrator page)
## used in RemoveMetadata and AddMetadata
# used in UpdateMetadata
# not (list1 -> list2) == (list1 and not list2) == (list1 - list2)
# >>> list1Name and list2Name must not be lists of lists (because of split/join)
proc ListNegatedImplication {list1Name list2Name} {
upvar $list1Name list1
upvar $list2Name list2
if [string equal {} $list2] {return $list1} ;# added by GJFB in 2010-12-10
set list {}
# split and join below solves error like list element in quotes followed by "," instead of space
# example:
# split {data "aaa", were}
# => data {"aaa",} were
# join {data {"aaa",} were}
# => data "aaa", were
foreach element [split $list1] {
if {[lsearch -exact [split $list2] $element] < 0} {
lappend list $element
}
}
return [join $list]
}
if 0 {
set list1 {a b c d}
set list2 {a c e f}
ListNegatedImplication list1 list2
# => b d
set list1 {a b c a}
set list2 {a b c d}
ListNegatedImplication list1 list2
# => {}
}
# ListNegatedImplication - end
# ----------------------------------------------------------------------
# ListNegatedImplication2
# added by GJFB in 2022-10-08
# used in UpdateContentDescriptionFile only
# not (list1 -> list2) == (list1 and not list2) == (list1 - list2)
# >>> must be used when list1Name and list2Name might be lists of lists (for example when an image name contains white spaces like 'WhatsApp Image 2022-08-31 at 14.10.26.jpeg')
proc ListNegatedImplication2 {list1Name list2Name} {
upvar $list1Name list1
upvar $list2Name list2
if [string equal {} $list2] {return $list1} ;# added by GJFB in 2010-12-10
set list {}
foreach element1 $list1 {
set foundFlag 0
foreach element2 $list2 {
if [string equal $element1 $element2] {
set foundFlag 1
break
}
}
if !$foundFlag {lappend list $element1}
}
return $list
}
if 0 {
set list1 {a b c d}
set list2 {a c e f}
ListNegatedImplication2 list1 list2
# => b d
set list1 {a b c a}
set list2 {a b c d}
ListNegatedImplication2 list1 list2
# => {}
}
# ListNegatedImplication2 - end
# ----------------------------------------------------------------------