shell.tcl

   1 # $Id: shell.tcl,v 1.5 1998-05-20 12:27:45 adam Exp $
   2 #
   3
   4 if {[catch {ir-log-init all irtcl shell.log}]} {
   5     set e [info sharedlibextension]
   6     puts "Loading irtcl$e ..."
   7     load ./irtcl$e irtcl
   8     ir-log-init all irtcl shell.log
   9 }
  10
  11 source display.tcl
  12
  13 ir z
  14
  15 set pref(base) Default
  16 set pref(format) usmarc
  17
  18 proc help {} {
  19     puts "Commands:"
  20     puts " target <host>"
  21     puts " base <base>"
  22     puts " format <format>"
  23     puts " find <query>"
  24     puts " show <offset> <number>"
  25     puts ""
  26 }
  27
  28 proc fail-response {} {
  29     global ok
  30     set ok -1
  31 }
  32 proc target {name} {
  33     global ok pref
  34
  35     set ok 0
  36     z disconnect
  37     z failback {fail-response}
  38     z callback {connect-response}
  39     if [catch "z connect $name"] {
  40         fail-response
  41     } elseif {$ok == 0} {
  42         vwait ok
  43     }
  44     if {$ok == 1} {
  45         puts "Connected and initialized."
  46     } else {
  47         puts "Failed."
  48     }
  49     return {}
  50 }
  51
  52 proc base {base} {
  53     global pref
  54     set pref(base) $base
  55 }
  56
  57 proc format {format} {
  58     global pref
  59     set pref(format) $format
  60 }
  61
  62 proc connect-response {} {
  63     z callback {init-response}
  64     z init
  65 }
  66
  67 proc init-response {} {
  68     global ok pref
  69
  70     set ok 1
  71     ir-set z.1 z
  72 }
  73
  74 proc find-response {z} {
  75     set sstatus [$z searchStatus]
  76     if {$sstatus} {
  77         set h [$z resultCount]
  78         puts "Search ok. $h hits"
  79     } else {
  80         puts "Search failed"
  81     }
  82     common-response $z 1
  83 }
  84
  85 proc common-response {z from} {
  86     global ok pref
  87
  88     set ok 1
  89     set status [$z responseStatus]
  90     switch [lindex $status 0] {
  91     NSD {
  92             puts -nonewline "NSD"
  93             puts -nonewline [lindex $status 1]
  94             puts -nonewline " "
  95             puts -nonewline [lindex $status 2]
  96             puts -nonewline ": "
  97             puts -nonewline [lindex $status 3]
  98             puts ""
  99         }
 100     DBOSD {
 101             puts "DBOSD"
 102             set to [expr $from + [$z numberOfRecordsReturned]]
 103             for {set i $from} {$i < $to} {incr i} {
 104                 if {[$z type $i] == ""} {
 105                     break
 106                 }
 107                 puts "\# $i"
 108                 display $z $i
 109             }
 110         }
 111     }
 112 }
 113
 114 proc show {{from 1} {number 1}} {
 115     global ok pref
 116
 117     set ok 0
 118     z callback "common-response z.1 $from"
 119     z.1 present $from $number
 120     vwait ok
 121     return {}
 122 }
 123
 124 proc explain {query} {
 125     global ok pref
 126
 127     set ok 0
 128     z.1 databaseNames IR-Explain-1
 129     z.1 preferredRecordSyntax explain
 130     z callback {find-response z.1}
 131     z.1 search "@attrset exp1 @attr 1=1 @attr 2=3 @attr 3=3 @attr 4=3 $query"
 132     vwait ok
 133     return {}
 134 }
 135
 136 proc find {query} {
 137     global ok pref
 138
 139     set ok 0
 140     z.1 databaseNames $pref(base)
 141     z.1 preferredRecordSyntax $pref(format)
 142     z callback {find-response z.1}
 143     z.1 search $query
 144     vwait ok
 145     return {}
 146 }
 147