shell.tcl

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