shell.tcl

   1 # $Id: shell.tcl,v 1.8 2002-03-21 11:11:53 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 " sort <attr> <flag>"
  25     puts " show <offset> <number>"
  26     puts ""
  27 }
  28
  29 proc fail-response {} {
  30     global ok
  31     set ok -1
  32 }
  33 proc target {name} {
  34     global ok pref
  35
  36     set ok 0
  37     z disconnect
  38     z failback {fail-response}
  39     z callback {connect-response}
  40     if [catch "z connect $name"] {
  41         fail-response
  42     } elseif {$ok == 0} {
  43         vwait ok
  44     }
  45     if {$ok == 1} {
  46         puts "Connected and initialized."
  47     } else {
  48         puts "Failed."
  49     }
  50     return {}
  51 }
  52
  53 proc base {base} {
  54     global pref
  55     set pref(base) $base
  56 }
  57
  58 proc format {format} {
  59     global pref
  60     set pref(format) $format
  61 }
  62
  63 proc connect-response {} {
  64     z callback {init-response}
  65     z init
  66 }
  67
  68 proc init-response {} {
  69     global ok pref
  70
  71     set ok 1
  72     ir-set z.1 z
  73 }
  74
  75 proc find-response {z} {
  76     set sstatus [$z searchStatus]
  77     if {$sstatus} {
  78         set h [$z resultCount]
  79         puts "Search ok. $h hits"
  80         set terms [$z searchResult]
  81         foreach tc $terms {
  82             puts "[lindex $tc 0]: [lindex $tc 1]"
  83         }
  84     } else {
  85         puts "Search failed"
  86     }
  87     common-response $z 1
  88 }
  89
  90 proc sort-response {z} {
  91     global ok
  92     set sstatus [$z sortStatus]
  93     puts "Sort Status: $sstatus"
  94     set ok 1
  95 }
  96
  97 proc common-response {z from} {
  98     global ok pref
  99
 100     set ok 1
 101     set status [$z responseStatus]
 102     switch [lindex $status 0] {
 103     NSD {
 104             puts -nonewline "NSD"
 105             puts -nonewline [lindex $status 1]
 106             puts -nonewline " "
 107             puts -nonewline [lindex $status 2]
 108             puts -nonewline ": "
 109             puts -nonewline [lindex $status 3]
 110             puts ""
 111         }
 112     DBOSD {
 113             puts "DBOSD"
 114             set to [expr $from + [$z numberOfRecordsReturned]]
 115             for {set i $from} {$i < $to} {incr i} {
 116                 if {[$z type $i] == ""} {
 117                     break
 118                 }
 119                 puts "\# $i"
 120                 display $z $i
 121             }
 122         }
 123     }
 124 }
 125
 126 proc show {{from 1} {number 1}} {
 127     global ok pref
 128
 129     set ok 0
 130     z callback "common-response z.1 $from"
 131     z.1 present $from $number
 132     vwait ok
 133     return {}
 134 }
 135
 136 proc explain {query} {
 137     global ok pref
 138
 139     set ok 0
 140     z.1 databaseNames IR-Explain-1
 141     z.1 preferredRecordSyntax explain
 142     z callback {find-response z.1}
 143     z.1 search "@attrset exp1 @attr 1=1 @attr 2=3 @attr 3=3 @attr 4=3 $query"
 144     vwait ok
 145     return {}
 146 }
 147
 148 proc find {query} {
 149     global ok pref
 150
 151     set ok 0
 152     z.1 databaseNames $pref(base)
 153     z.1 preferredRecordSyntax $pref(format)
 154     z callback {find-response z.1}
 155     z.1 search $query
 156     vwait ok
 157     return {}
 158 }
 159
 160 proc sort {query flags} {
 161     global ok pref
 162
 163     set ok 0
 164     z callback {sort-response z.1}
 165     z.1 sort "$query $flags"
 166     vwait ok
 167     return {}
 168 }
 169