// mk4tcl.cpp -- // $Id: mk4tcl.cpp,v 1.58 2004/01/26 09:54:45 jcw Exp $ // This is part of Metakit, see http://www.equi4.com/metakit/ #include "mk4tcl.h" #include "mk4io.h" #if MKSQL #include "mksql.h" #endif #ifndef _WIN32_WCE #include #endif #include #include #include #ifndef EINVAL #define EINVAL 9 #endif // stub interface code, removes the need to link with libtclstub*.a #ifdef USE_TCL_STUBS #include "stubtcl.h" #else #define MyInitStubs(x) 1 #endif /////////////////////////////////////////////////////////////////////////////// // Defined in this file: class MkPath; class MkWorkspace; class Tcl; class MkTcl; /////////////////////////////////////////////////////////////////////////////// // inc'ed whenever a datafile is closed, forces relookup of all paths static int generation; TCL_DECLARE_MUTEX(mkMutex) // use a single monolithic mutex for now // put code in this file as a mutex is static in Windows int Mk_EvalObj(Tcl_Interp* ip_, Tcl_Obj* cmd_) { Tcl_MutexUnlock(&mkMutex); int e = Tcl_EvalObj(ip_, cmd_); Tcl_MutexLock(&mkMutex); return e; } // moved out of member func scope to please HP-UX's aCC: static const char* getCmds [] = { "-size", 0 }; static const char* viewCmds [] = { "layout", "delete", "size", "properties", "locate", "restrict", "open", "new", "info", 0 }; static const char* cursorCmds [] = { "create", "position", "incr", 0 }; static const char* channelCmds [] = { "read", "write", "append", 0 }; ///////////////////////////////////////////////////////////////////////////// // Utility code: return next token up to char < '0', and // advance the string pointer past following character. c4_String f4_GetToken(const char*& str_) { d4_assert(str_); const char* p = str_; while (*p >= '0') ++p; c4_String result (str_, p - str_); if (*p) ++p; str_ = p; return result; } /////////////////////////////////////////////////////////////////////////////// // Utility code: true if value contains a word starting with the given prefix bool MatchOneKeyword(const char* value_, const c4_String& crit_) { int n = crit_.GetLength(); if (n == 0) return true; char cu = (char) toupper(crit_[0]); char cl = (char) tolower(crit_[0]); while (*value_) { c4_String s (value_, n); if (s.CompareNoCase(crit_) == 0) return true; while (*++value_) if ((*value_ == cu || *value_ == cl) && !isalnum(value_[-1])) break; } return false; } /////////////////////////////////////////////////////////////////////////////// // A "storage in a storage" strategy class for Metakit // Adapted from MkWrap, the Python interface class SiasStrategy : public c4_Strategy { public: c4_Storage _storage; c4_View _view; c4_BytesProp _memo; int _row; t4_i32 _position; Tcl_Channel _chan; int _validMask; int _watchMask; Tcl_Interp* _interp; SiasStrategy (c4_Storage& storage_, const c4_View& view_, const c4_BytesProp& memo_, int row_) : _storage (storage_), _view (view_), _memo (memo_), _row (row_), _position (0), _interp (0) { // set up mapping if the memo itself is mapped in its entirety c4_Strategy& strat = storage_.Strategy(); if (strat._mapStart != 0) { c4_RowRef r = _view[_row]; c4_Bytes data = _memo(r).Access(0); const t4_byte* ptr = data.Contents(); if (data.Size() == _memo(r).GetSize() && strat._mapStart != 0 && ptr >= strat._mapStart && ptr - strat._mapStart < strat._dataSize) { _mapStart = ptr; _dataSize = data.Size(); } } } virtual ~SiasStrategy () { _view = c4_View(); _mapStart = 0; _dataSize = 0; if (_chan != 0) Tcl_UnregisterChannel(_interp, _chan); } virtual void DataSeek(t4_i32 position_) { _position = position_; } virtual int DataRead(t4_i32 pos_, void* buffer_, int length_) { if (pos_ != ~0) _position = pos_; int i = 0; while (i < length_) { c4_Bytes data = _memo(_view[_row]).Access(_position + i, length_ - i); int n = data.Size(); if (n <= 0) break; memcpy((char*) buffer_ + i, data.Contents(), n); i += n; } _position += i; return i; } virtual void DataWrite(t4_i32 pos_, const void* buffer_, int length_) { if (pos_ != ~0) _position = pos_; c4_Bytes data (buffer_, length_); if (_memo(_view[_row]).Modify(data, _position)) _position += length_; else ++_failure; } virtual void DataCommit(t4_i32 newSize_) { if (newSize_ > 0) _memo(_view[_row]).Modify(c4_Bytes (), newSize_); } virtual void ResetFileMapping() { _mapStart = 0; // never called, but just in case } }; /////////////////////////////////////////////////////////////////////////////// // New in 1.2: channel interface to memo fields typedef SiasStrategy MkChannel; typedef struct { Tcl_Event header; MkChannel *chan; } MkEvent; static int mkEventProc(Tcl_Event *evPtr, int flags) { MkEvent *me = (MkEvent*)evPtr; if (!(flags & TCL_FILE_EVENTS)) return 0; Tcl_NotifyChannel(me->chan->_chan, me->chan->_watchMask); return 1; } static void mkCheckProc(ClientData instanceData, int flags) { MkChannel* chan = (MkChannel*) instanceData; if (!(flags & TCL_FILE_EVENTS)) return; MkEvent *evPtr = (MkEvent*)Tcl_Alloc(sizeof(MkEvent)); evPtr->header.proc = mkEventProc; evPtr->chan = chan; Tcl_QueueEvent( (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); } static void mkSetupProc(ClientData instanceData, int flags) { MkChannel* chan = (MkChannel*) instanceData; Tcl_Time blockTime = { 0, 0}; if (!(flags & TCL_FILE_EVENTS)) return; if (chan->_watchMask) Tcl_SetMaxBlockTime(&blockTime); } static int mkEventFilter( Tcl_Event *evPtr, ClientData instanceData) { MkEvent* me = (MkEvent*) evPtr; MkChannel* chan = (MkChannel*) instanceData; return evPtr->proc == mkEventProc && me->chan == chan; } static int mkClose (ClientData instanceData, Tcl_Interp* interp) { MkChannel* chan = (MkChannel*) instanceData; // Tcl_DeleteEventSource(mkSetupProc, mkCheckProc, (ClientData) chan); Tcl_DeleteEvents(mkEventFilter, (ClientData) chan); delete chan; return TCL_OK; } static int mkInput (ClientData instanceData, char* buf, int toRead, int* errorCodePtr) { MkChannel* chan = (MkChannel*) instanceData; return chan->DataRead(~0, buf, toRead); } static int mkOutput (ClientData instanceData, const char* buf, int toWrite, int* errorCodePtr) { MkChannel* chan = (MkChannel*) instanceData; chan->DataWrite(~0, buf, toWrite); if (chan->_failure == 0) return toWrite; *errorCodePtr = EINVAL; // hm, bad choice of error code return -1; } static int mkSeek (ClientData instanceData, long offset, int seekMode, int* errorCodePtr) { MkChannel* chan = (MkChannel*) instanceData; switch (seekMode) { default: *errorCodePtr = EINVAL; // hm, bad choice of error code return -1; case 0: break; case 1: offset += chan->_position; break; case 2: offset += chan->_memo (chan->_view[chan->_row]).GetSize(); break; } chan->DataSeek(offset); return offset; } static void mkWatchChannel (ClientData instanceData, int mask) { MkChannel* chan = (MkChannel*) instanceData; Tcl_Time blockTime = { 0, 0 }; /* * Since the file is always ready for events, we set the block time * to zero so we will poll. */ chan->_watchMask = mask & chan->_validMask; if (chan->_watchMask) { Tcl_SetMaxBlockTime(&blockTime); } } static int mkGetFile (ClientData instanceData, int direction, ClientData* handlePtr) { return TCL_ERROR; } static Tcl_ChannelType mkChannelType = { "mk", /* Type name. */ 0, /* Set blocking/nonblocking behaviour. NULL'able */ mkClose, /* Close channel, clean instance data */ mkInput, /* Handle read request */ (Tcl_DriverOutputProc*) mkOutput, /* Handle write request */ (Tcl_DriverSeekProc*) mkSeek, /* Move location of access point. NULL'able */ 0, /* Set options. NULL'able */ 0, /* Get options. NULL'able */ (Tcl_DriverWatchProc*) mkWatchChannel, /* Initialize notifier */ mkGetFile /* Get OS handle from the channel. */ }; /////////////////////////////////////////////////////////////////////////////// // Utility code: get a Metakit item and convert it to a Tcl object Tcl_Obj* GetAsObj(const c4_RowRef& row_, const c4_Property& prop_, Tcl_Obj* obj_) { if (obj_ == 0) obj_ = Tcl_NewObj(); switch (prop_.Type()) { case 'S': { const char* p = ((c4_StringProp&) prop_) (row_); Tcl_SetStringObj(obj_, (char*) p, -1); } break; case 'B': { c4_Bytes temp; prop_ (row_).GetData(temp); Tcl_SetByteArrayObj(obj_, (t4_byte*) temp.Contents(), temp.Size()); } break; case 'F': Tcl_SetDoubleObj(obj_, ((c4_FloatProp&) prop_) (row_)); break; case 'D': Tcl_SetDoubleObj(obj_, ((c4_DoubleProp&) prop_) (row_)); break; #ifdef TCL_WIDE_INT_TYPE case 'L': Tcl_SetWideIntObj(obj_, ((c4_LongProp&) prop_) (row_)); break; #endif case 'I': Tcl_SetLongObj(obj_, ((c4_IntProp&) prop_) (row_)); break; case 'V': { c4_View view = ((c4_ViewProp&) prop_) (row_); Tcl_SetIntObj(obj_, view.GetSize()); } break; default: { KeepRef keeper (obj_); // a funny way to release the value } return 0; } return obj_; } /////////////////////////////////////////////////////////////////////////////// // Utility code: set a Metakit item and convert it from a Tcl object int SetAsObj(Tcl_Interp* interp, const c4_RowRef& row_, const c4_Property& prop_, Tcl_Obj* obj_) { int e = TCL_OK; switch (prop_.Type()) { case 'S': { int len; const char* ptr = Tcl_GetStringFromObj(obj_, &len); prop_ (row_).SetData(c4_Bytes (ptr, len + 1)); } break; case 'B': { int len; const t4_byte* ptr = Tcl_GetByteArrayFromObj(obj_, &len); prop_ (row_).SetData(c4_Bytes (ptr, len)); } break; case 'F': { double value = 0; e = Tcl_GetDoubleFromObj(interp, obj_, &value); if (e == TCL_OK) ((c4_FloatProp&) prop_) (row_) = (float) value; } break; case 'D': { double value = 0; e = Tcl_GetDoubleFromObj(interp, obj_, &value); if (e == TCL_OK) ((c4_DoubleProp&) prop_) (row_) = value; } break; #ifdef TCL_WIDE_INT_TYPE case 'L': { Tcl_WideInt value = 0; e = Tcl_GetWideIntFromObj(interp, obj_, &value); if (e == TCL_OK) ((c4_LongProp&) prop_) (row_) = value; } break; #endif case 'I': { long value = 0; e = Tcl_GetLongFromObj(interp, obj_, &value); if (e == TCL_OK) ((c4_IntProp&) prop_) (row_) = value; } break; default: Tcl_SetResult(interp, "unsupported property type", TCL_STATIC); e = TCL_ERROR; } return e; } /////////////////////////////////////////////////////////////////////////////// // In Tcl, streaming I/O uses the Tcl channel interface for loading/saving. class c4_TclStream : public c4_Stream { Tcl_Channel _stream; public: c4_TclStream (Tcl_Channel stream_); virtual ~c4_TclStream (); virtual int Read(void* buffer_, int length_); virtual bool Write(const void* buffer_, int length_); }; c4_TclStream::c4_TclStream (Tcl_Channel stream_) : _stream (stream_) { } c4_TclStream::~c4_TclStream () { } int c4_TclStream::Read(void* buffer_, int length_) { return Tcl_Read(_stream, (char*) buffer_, length_); } bool c4_TclStream::Write(const void* buffer_, int length_) { return Tcl_Write(_stream, (char*) buffer_, length_) >= 0; } /////////////////////////////////////////////////////////////////////////////// MkPath::MkPath (MkWorkspace& ws_, const char*& path_, Tcl_Interp* interp) : _refs (1), _ws (&ws_), _path (path_), _currGen (generation) { // if this view is not part of any storage, make a new temporary row if (_path.IsEmpty()) { _path = ws_.AllocTempRow(); AttachView(interp); } else { int n = AttachView(interp); path_ += n; // move past all processed characters // but trim white space and unprocessed tail from stored path while (n > 0 && _path[n-1] < '0') --n; if (n < _path.GetLength()) _path = _path.Left(n); } } MkPath::~MkPath () { if (_ws != 0) _ws->ForgetPath(this); } static c4_View OpenMapped(c4_View v_, int col_, int row_) { if (col_ < 0) return c4_View (); const c4_Property& prop = v_.NthProperty(col_); d4_assert(prop.Type() == 'V'); if (prop.Type() != 'V') return c4_View (); c4_View vw = ((c4_ViewProp&) prop) (v_[row_]); c4_String name = prop.Name(); int h = v_.FindPropIndexByName(name + "_H1"); if (h >= 0) { const c4_Property& proph = v_.NthProperty(h); if (proph.Type() == 'V') { c4_View vwh = ((c4_ViewProp&) proph) (v_[row_]); vw = vw.Hash(vwh,1); } } return vw; } int MkPath::AttachView(Tcl_Interp* /*interp*/) { const char* base = _path; const char* p = base; // The format of a path description is: // // storage '.' viewname [ '!' row# '.' viewprop ]* // or // storage '.' viewname [ '!' row# '.' viewprop ]* '!' row# // // In the second case, the trailing row# is ignored. MkWorkspace::Item* ip = _ws != 0 ? _ws->Find(f4_GetToken(p)) : 0; if (ip != 0) { // 16-1-2003: allow path reference to root view (i.e. storage itself) if (*p == 0) { _view = ip->_storage; return p - base; } #if 0 c4_View root = *ip->_storage; int col = root.FindPropIndexByName(f4_GetToken(p)); _view = OpenMapped(root, col, 0); #else _view = ip->_storage.View(f4_GetToken(p)); #endif while (*p) { if (!isdigit(*p)) { _view = c4_View (); // bad stuff, bail out with an empty view break; } const char* q = p; int r = atoi(f4_GetToken(p)); if (!*p) return q - base; // return partial number of chars processed // A future version could parse derived view expressions here. // Perhaps this could be done as Metakit property expressions. int n = _view.FindPropIndexByName(f4_GetToken(p)); if (n < 0) return q - base; // make sure the property exists const c4_Property& prop = _view.NthProperty(n); if (prop.Type() != 'V') return q - base; // make sure it's a subview #if 0 _view = OpenMapped(_view, n, r); #else _view = ((c4_ViewProp&) prop) (_view[r]);; #endif } } else _view = c4_View (); return p - base; // return pointer to ending null byte } int MkPath::Refs(int diff_) { d4_assert(-1 <= diff_ && diff_ <= +1); _refs += diff_; d4_assert(_refs >= 0); if (_refs == 0 && diff_ < 0) { delete this; return 0; } return _refs; } /////////////////////////////////////////////////////////////////////////////// c4_PtrArray* MkWorkspace::Item::_shared = 0; MkWorkspace::Item::Item (const char* name_, const char* fileName_, int mode_, c4_PtrArray& items_, int index_, bool share_) : _name (name_), _fileName (fileName_), _items (items_), _index (index_) { ++generation; // make sure all cached paths refresh on next access if (*fileName_) { c4_Storage s (fileName_, mode_); if (!s.Strategy().IsValid()) return; _storage = s; } if (_index >= _items.GetSize()) _items.SetSize(_index + 1); _items.SetAt(_index, this); if (share_) { if (_shared == 0) _shared = new c4_PtrArray; _shared->Add(this); } } MkWorkspace::Item::~Item () { //! ForceRefresh(); // all views referring to this datafile are made invalid for (int i = 0; i < _paths.GetSize(); ++i) { MkPath* path = (MkPath*) _paths.GetAt(i); if (_index > 0) path->_view = c4_View (); path->_path = "?"; // make sure it never matches path->_currGen = -1; // make sure lookup is retried on next use // 24-01-2003: paths should not clean up workspaces once exiting path->_ws = 0; // TODO: get rid of generations, use a "_valid" flag instead } ++generation; // make sure all cached paths refresh on next access if (_index < _items.GetSize()) { d4_assert(_items.GetAt(_index) == this || _items.GetAt(_index) == 0); _items.SetAt(_index, 0); } if (_shared != 0) { for (int i = 0; i < _shared->GetSize(); ++i) if (_shared->GetAt(i) == this) { _shared->RemoveAt(i); break; } if (_shared->GetSize() == 0) { delete _shared; _shared = 0; } } } void MkWorkspace::Item::ForceRefresh() { // all views referring to this datafile are cleared for (int i = 0; i < _paths.GetSize(); ++i) { MkPath* path = (MkPath*) _paths.GetAt(i); path->_view = c4_View (); } ++generation; // make sure all cached paths refresh on next access } MkWorkspace::MkWorkspace (Tcl_Interp* ip_) : _interp (ip_) { new Item ("", "", 0, _items, 0); // never uses entry zero (so atoi failure in ForgetPath is harmless) _usedRows = _usedBuffer.SetBufferClear(16); // no realloc for first 16 temp rows } MkWorkspace::~MkWorkspace () { CleanupCommands(); for (int i = _items.GetSize(); --i >= 0; ) delete Nth(i); // need this to prevent recursion in Tcl_DeleteAssocData in 8.2 (not 8.0!) Tcl_SetAssocData(_interp, "mk4tcl", 0, 0); Tcl_DeleteAssocData(_interp, "mk4tcl"); } void MkWorkspace::DefCmd(MkTcl* cmd_) { _commands.Add(cmd_); } MkWorkspace::Item* MkWorkspace::Define(const char* name_, const char* fileName_, int mode_, bool share_) { Item *ip = Find(name_); if (ip == 0) { int n = -1; while (++n < _items.GetSize()) if (Nth(n) == 0) break; ip = new Item (name_, fileName_, mode_, _items, n, share_); if (*fileName_ != 0 && !ip->_storage.Strategy().IsValid()) { delete ip; return 0; } } return ip; } MkWorkspace::Item* MkWorkspace::Find(const char* name_) const { for (int i = 0; i < _items.GetSize(); ++i) { Item* ip = Nth(i); if (ip && ip->_name.Compare(name_) == 0) return ip; } if (Item::_shared != 0) // look in the shared pool, if there is one { for (int j = 0; j < Item::_shared->GetSize(); ++j) { Item* ip = (Item*) Item::_shared->GetAt(j); if (ip && ip->_name == name_) return ip; } } return 0; } int MkWorkspace::NumItems() const { return _items.GetSize(); } MkWorkspace::Item* MkWorkspace::Nth(int index_) const { return (Item*) _items.GetAt(index_); } MkPath* MkWorkspace::AddPath(const char*& name_, Tcl_Interp* interp) { const char* p = name_; Item* ip = Find(f4_GetToken(p)); if (ip == 0) { ip = Nth(0); d4_assert(ip != 0); name_ = ""; // no such tag, assign a temporary one instead } else for (int i = 0; i < ip->_paths.GetSize(); ++i) { MkPath* path = (MkPath*) ip->_paths.GetAt(i); d4_assert(path != 0); if (path->_path.CompareNoCase(name_) == 0 && path->_currGen == generation) { path->Refs(+1); return path; } } MkPath* newPath = new MkPath (*this, name_, interp); ip->_paths.Add(newPath); return newPath; } c4_String MkWorkspace::AllocTempRow() { int i; // find an unused row for (i = 1; i < _usedBuffer.Size(); ++i) if (_usedRows[i] == 0) break; // allocate new vec if old one is too small, doubling it in size if (i >= _usedBuffer.Size()) { c4_Bytes temp; t4_byte* tempPtr = temp.SetBufferClear(2*i+1); memcpy(tempPtr, _usedRows, _usedBuffer.Size()); _usedBuffer.Swap(temp); _usedRows = tempPtr; c4_View v = Nth(0)->_storage.View(""); v.SetSize(_usedBuffer.Size()); } // flag it as being in use _usedRows[i] = 1; // temporary rows have special names char buf[20]; sprintf(buf, "._!%d._", i); return buf; } void MkWorkspace::ForgetPath(const MkPath* path_) { const char* p = path_->_path; Item* ip = Find(f4_GetToken(p)); if (ip != 0) { for (int j = 0; j < ip->_paths.GetSize(); ++j) if ((MkPath*) ip->_paths.GetAt(j) == path_) { ip->_paths.RemoveAt(j); break; } // last ref to a temporary row determines when to release it if (ip == Nth(0)) { int n = atoi(((const char*) path_->_path) + 3); d4_assert(_usedRows[n] != 0); _usedRows[n] = 0; } } } void MkWorkspace::Invalidate(const MkPath& path_) { const char* p = path_._path; c4_String prefix = path_._path + "!"; int n = prefix.GetLength(); Item* ip = Find(f4_GetToken(p)); if (ip != 0) { for (int j = 0; j < ip->_paths.GetSize(); ++j) { MkPath* entry = (MkPath*) ip->_paths.GetAt(j); if (strncmp(entry->_path, prefix, n) == 0) entry->_currGen = -1; // the next use will reattach } } } /////////////////////////////////////////////////////////////////////////////// // Translate between the Metakit and Tcl-style datafile structure descriptions static c4_String KitToTclDesc(const char* desc_) { c4_Bytes temp; char* p = (char*) temp.SetBuffer(3 * strlen(desc_) + 100); while (*desc_) { char* q = p; // assume normal property while (isalnum(*desc_) || *desc_ == '_' || *desc_ == ':') *p++ = *desc_++; // strip a trailing ':S' if (p[-2] == ':' && p[-1] == 'S') p -= 2; // at end of property, process commas and brackets switch (*desc_++) { // defensive coding, this cannot happen case 0: --desc_; break; // opening bracket "xxx[" --> "{xxx {" case '[': { c4_String name (q, p - q); *q++ = '{'; strcpy(q, name); ++p; *p++ = ' '; *p++ = '{'; } break; // opening bracket "]" --> "}}" case ']': { *p++ = '}'; *p++ = '}'; } break; // comma separator "," --> " " case ',': *p++ = ' '; } } *p++ = 0; return (const char*) temp.Contents(); } /////////////////////////////////////////////////////////////////////////////// // // Interface to Tcl 8.0 type mechanism, defines a new "mkProperty" datatype // // Since properties are immutable, we don't need most of the calls. static void FreePropertyInternalRep(Tcl_Obj* propPtr); static void DupPropertyInternalRep(Tcl_Obj*, Tcl_Obj*) { d4_assert(false); } static void UpdateStringOfProperty(Tcl_Obj*) { d4_assert(false); } static int SetPropertyFromAny(Tcl_Interp*, Tcl_Obj*) { d4_assert(false); return TCL_OK; } static Tcl_ObjType mkPropertyType = { "mkProperty", // name FreePropertyInternalRep, // freeIntRepProc DupPropertyInternalRep, // dupIntRepProc UpdateStringOfProperty, // updateStringProc SetPropertyFromAny // setFromAnyProc }; /////////////////////////////////////////////////////////////////////////////// const c4_Property& AsProperty(Tcl_Obj* objPtr, const c4_View& view_) { if (objPtr->typePtr != &mkPropertyType) { Tcl_ObjType* oldTypePtr = objPtr->typePtr; char type = 'S'; int length; char* string = Tcl_GetStringFromObj(objPtr, &length); if (length > 2 && string[length-2] == ':') { type = string[length-1]; length -= 2; } else // look int the view to try to determine the type { int n = view_.FindPropIndexByName(string); if (n >= 0) type = view_.NthProperty(n).Type(); } c4_Property* prop = new c4_Property (type, c4_String (string, length)); if (oldTypePtr && oldTypePtr->freeIntRepProc) oldTypePtr->freeIntRepProc(objPtr); objPtr->typePtr = &mkPropertyType; // use a (char*), because the Mac wants it, others use (void*) objPtr->internalRep.otherValuePtr = (char*) prop; } return *(c4_Property*) objPtr->internalRep.otherValuePtr; } static void FreePropertyInternalRep(Tcl_Obj* propPtr) { delete (c4_Property*) propPtr->internalRep.otherValuePtr; } /////////////////////////////////////////////////////////////////////////////// // // Interface to Tcl 8.0 type mechanism, defines a new "mkCursor" datatype static void FreeCursorInternalRep(Tcl_Obj* propPtr); static void DupCursorInternalRep(Tcl_Obj* srcPtr, Tcl_Obj* copyPtr); //static int SetCursorFromAny(Tcl_Interp* interp, Tcl_Obj* objPtr); static void UpdateStringOfCursor(Tcl_Obj* propPtr); static Tcl_ObjType mkCursorType = { "mkCursor", // name FreeCursorInternalRep, // freeIntRepProc DupCursorInternalRep, // dupIntRepProc UpdateStringOfCursor, // updateStringProc SetCursorFromAny // setFromAnyProc }; /////////////////////////////////////////////////////////////////////////////// // // Cursors in Tcl are implemented as a pointer to an MkPath plus an index. MkPath& AsPath(Tcl_Obj* obj_) { d4_assert(obj_->typePtr == &mkCursorType); d4_assert(obj_->internalRep.twoPtrValue.ptr2 != 0); return *(MkPath*) obj_->internalRep.twoPtrValue.ptr2; } int& AsIndex(Tcl_Obj* obj_) { d4_assert(obj_->typePtr == &mkCursorType); d4_assert(obj_->internalRep.twoPtrValue.ptr2 != 0); return (int&) obj_->internalRep.twoPtrValue.ptr1; } static void FreeCursorInternalRep(Tcl_Obj* cursorPtr) { AsPath(cursorPtr).Refs(-1); } static void DupCursorInternalRep(Tcl_Obj* srcPtr, Tcl_Obj* copyPtr) { AsPath(srcPtr).Refs(+1); copyPtr->internalRep = srcPtr->internalRep; copyPtr->typePtr = &mkCursorType; } int SetCursorFromAny(Tcl_Interp* interp, Tcl_Obj* objPtr) { // force a relookup if the this object is of the wrong generation if (objPtr->typePtr == &mkCursorType && AsPath(objPtr)._currGen != generation) { // make sure we have a string representation around if (objPtr->bytes == 0) UpdateStringOfCursor(objPtr); // get rid of the object form FreeCursorInternalRep(objPtr); objPtr->typePtr = 0; } if (objPtr->typePtr != &mkCursorType) { Tcl_ObjType* oldTypePtr = objPtr->typePtr; const char* string = Tcl_GetStringFromObj(objPtr, 0); if (oldTypePtr && oldTypePtr->freeIntRepProc) oldTypePtr->freeIntRepProc(objPtr); // dig up the workspace used in this interpreter MkWorkspace* work = (MkWorkspace*) Tcl_GetAssocData(interp, "mk4tcl", 0); objPtr->typePtr = &mkCursorType; objPtr->internalRep.twoPtrValue.ptr2 = // cast required for Mac (char*) (void*) work->AddPath(string, interp); AsIndex(objPtr) = isdigit(*string) ? atoi(string) : -1; } return TCL_OK; } static void UpdateStringOfCursor(Tcl_Obj* cursorPtr) { c4_String s = AsPath(cursorPtr)._path; int index = AsIndex(cursorPtr); if (index >= 0) { char buf [20]; sprintf(buf, "%s%d", s.IsEmpty() ? "" : "!", index); s += buf; } cursorPtr->length = s.GetLength(); cursorPtr->bytes = strcpy(Tcl_Alloc(cursorPtr->length + 1), s); } static Tcl_Obj* AllocateNewTempRow(MkWorkspace& work_) { Tcl_Obj* result = Tcl_NewObj(); const char* empty = ""; MkPath* path = work_.AddPath(empty, 0); // path->_view.SetSize(1); result->typePtr = &mkCursorType; result->internalRep.twoPtrValue.ptr2 = (char*) (void*) path; AsIndex(result) = 0; Tcl_InvalidateStringRep(result); return result; } /////////////////////////////////////////////////////////////////////////////// // Helper class for the mk::select command, stores params and performs select TclSelector::TclSelector (Tcl_Interp* interp_, const c4_View& view_) : _interp (interp_), _view (view_), _temp (0), _first (0), _count (-1) { } TclSelector::~TclSelector () { for (int i = 0; i < _conditions.GetSize(); ++i) delete (Condition*) _conditions.GetAt(i); } // convert a property (or list of properties) to an empty view c4_View TclSelector::GetAsProps( Tcl_Obj* obj_) { c4_View result; Tcl_Obj* o; for (int i = 0; Tcl_ListObjIndex(_interp, obj_, i, &o) == TCL_OK && o != 0; ++i) result.AddProperty(AsProperty(o, _view)); return result; } int TclSelector::AddCondition(int id_, Tcl_Obj* props_, Tcl_Obj* value_) { c4_View props = GetAsProps(props_); if (props.NumProperties() > 0) _conditions.Add(new Condition (id_, props, Tcl_GetStringFromObj(value_, 0))); return TCL_OK; } bool TclSelector::MatchOneString(int id_, const char* value_, const c4_String& crit_) { switch (id_) { case 2: // -exact prop value : exact case-sensitive match return value_ == crit_; case 3: // -glob prop pattern : match "glob" expression wildcard return Tcl_StringMatch((char*) value_, (char*) (const char*) crit_) > 0; case 4: // -regexp prop pattern : match specified regular expression return Tcl_RegExpMatch(_interp, (char*) value_, (char*) (const char*) crit_) > 0; case 5: // -keyword prop prefix : match keyword in given property return MatchOneKeyword(value_, crit_); case 10: // -globnc prop pattern : match "glob", but not case sensitive return Tcl_StringCaseMatch(value_, crit_, 1) > 0; } return false; } bool TclSelector::Match(const c4_RowRef& row_) { // go through each condition and make sure they all match for (int i = 0; i < _conditions.GetSize(); ++i) { const Condition& cond = *(const Condition*) _conditions.GetAt(i); bool matched = false; // go through each property until one matches for (int j = 0; j < cond._view.NumProperties(); ++j) { const c4_Property& prop = cond._view.NthProperty(j); if (cond._id < 2) // use typed comparison as defined by Metakit { // set up a Tcl object, using the criterium string value Tcl_SetStringObj(_temp, (char*) (const char*) cond._crit, -1); c4_Row data; // this is *very* slow in Metakit 1.8 if (SetAsObj(_interp, data, prop, _temp) != TCL_OK) return false; // data is now a row with the criterium as single property matched = cond._id < 0 && data == row_ || cond._id == 0 && data <= row_ || cond._id > 0 && data >= row_; } else // use item value as a string { GetAsObj(row_, prop, _temp); const char* value = Tcl_GetStringFromObj(_temp, 0); matched = MatchOneString(cond._id, value, cond._crit); if (matched) break; } } if (!matched) return false; } return true; } // pick out criteria which specify an exact match void TclSelector::ExactKeyProps(const c4_RowRef& row_) { for (int i = 0; i < _conditions.GetSize(); ++i) { const Condition& cond = *(const Condition*) _conditions.GetAt(i); if (cond._id == -1 || cond._id == 2) { for (int j = 0; j < cond._view.NumProperties(); ++j) { const c4_Property& prop = cond._view.NthProperty(j); // 2001-05-30: inc/decref to clean up the string object KeepRef o = Tcl_NewStringObj(cond._crit, -1); SetAsObj(_interp, row_, prop, o); } } } } int TclSelector::DoSelect(Tcl_Obj* list_, c4_View* result_) { c4_IntProp pIndex ("index"); // normalize _first and _count to be in allowable range int n = _view.GetSize(); if (_first < 0) _first = 0; if (_first > n) _first = n; if (_count < 0) _count = n; if (_first + _count > n) _count = n - _first; c4_View result; result.SetSize(_count); // upper bound // keep a temporary around during the comparison loop _temp = Tcl_NewObj(); KeepRef keeper (_temp); // try to take advantage of key lookup structures c4_Row exact; ExactKeyProps(exact); if (exact.Container().NumProperties() > 0) _view.RestrictSearch(exact, _first, _count); // the matching loop where all the hard work is done for (n = 0; _first < _view.GetSize() && n < _count; ++_first) if (Match(_view [_first])) pIndex (result[n++]) = _first; result.SetSize(n); // set up sorting, this references/loads a lot of extra Metakit code const bool sorted = n > 0 && _sortProps.NumProperties() > 0; c4_View mapView; c4_View sortResult; if (sorted) { mapView = _view.RemapWith(result); sortResult = mapView.SortOnReverse(_sortProps, _sortRevProps); } // convert result to a Tcl list of ints if (list_ != 0) for (int i = 0; i < n; ++i) { // sorting means we have to lookup the index of the original again int pos = i; if (sorted) pos = mapView.GetIndexOf(sortResult [i]); // set up a Tcl integer which holds the selected row index KeepRef o = Tcl_NewIntObj(pIndex (result[pos])); if (Tcl_ListObjAppendElement(_interp, list_, o) != TCL_OK) return TCL_ERROR; } // added 2003/02/14: return intermediate view, if requested if (result_ != 0) *result_ = sorted ? sortResult : result; return TCL_OK; } /////////////////////////////////////////////////////////////////////////////// // The Tcl class is a generic interface to Tcl, providing some C++ wrapping Tcl::Tcl (Tcl_Interp* ip_) : interp (ip_) { } int Tcl::Fail(const char* msg_, int err_) { if (!_error) { if (msg_) Tcl_SetResult(interp, (char*) msg_, TCL_VOLATILE); _error = err_; } return _error; } Tcl_Obj* Tcl::tcl_GetObjResult() { return Tcl_GetObjResult(interp); } int Tcl::tcl_SetObjResult(Tcl_Obj* obj_) { Tcl_SetObjResult(interp, obj_); return _error; } int Tcl::tcl_ListObjLength(Tcl_Obj* obj_) { int result; _error = Tcl_ListObjLength(interp, obj_, &result); return _error ? -1 : result; } void Tcl::tcl_ListObjAppendElement(Tcl_Obj* obj_, Tcl_Obj* value_) { if (!_error) if (value_ == 0) Fail(); else _error = Tcl_ListObjAppendElement(interp, obj_, value_); } bool Tcl::tcl_GetBooleanFromObj(Tcl_Obj* obj_) { int value = 0; if (!_error) _error = Tcl_GetBooleanFromObj(interp, obj_, &value); return value != 0; } int Tcl::tcl_GetIntFromObj(Tcl_Obj* obj_) { int value = 0; if (!_error) _error = Tcl_GetIntFromObj(interp, obj_, &value); return value; } long Tcl::tcl_GetLongFromObj(Tcl_Obj* obj_) { long value = 0; if (!_error) _error = Tcl_GetLongFromObj(interp, obj_, &value); return value; } double Tcl::tcl_GetDoubleFromObj(Tcl_Obj* obj_) { double value = 0; if (!_error) _error = Tcl_GetDoubleFromObj(interp, obj_, &value); return value; } int Tcl::tcl_GetIndexFromObj(Tcl_Obj *obj_, const char **table_, char *msg_) { int index = -1; if (!_error) _error = Tcl_GetIndexFromObj(interp, obj_, (CONST84 char**) table_, msg_, 0, &index); return _error == TCL_OK ? index : -1; } long Tcl::tcl_ExprLongObj(Tcl_Obj *obj_) { long result = 0; if (!_error) _error = Tcl_ExprLongObj(interp, obj_, &result); return result; } Tcl_Obj* Tcl::GetValue(const c4_RowRef& row_, const c4_Property& prop_, Tcl_Obj* obj_) { obj_ = GetAsObj(row_, prop_, obj_); if (!obj_) Fail("unsupported property type"); return obj_; } Tcl_Obj* Tcl::tcl_NewStringObj(const char* str_, int len_) { return Tcl_NewStringObj((char*) str_, len_); } void Tcl::list2desc(Tcl_Obj* in_, Tcl_Obj* out_) { Tcl_Obj *o, **ov; int oc; if (Tcl_ListObjGetElements(0, in_, &oc, &ov) == TCL_OK && oc > 0) { char sep = '['; for (int i = 0; i < oc; ++i) { Tcl_AppendToObj(out_, &sep, 1); sep = ','; Tcl_ListObjIndex(0, ov[i], 0, &o); if (o != 0) Tcl_AppendObjToObj(out_, o); Tcl_ListObjIndex(0, ov[i], 1, &o); if (o != 0) list2desc(o, out_); } Tcl_AppendToObj(out_, "]", 1); } } /////////////////////////////////////////////////////////////////////////////// // The MkTcl class adds Metakit-specific utilities and all the command procs. int MkTcl::Dispatcher(ClientData cd, Tcl_Interp* ip, int oc, Tcl_Obj* const* ov) { MkTcl* self = (MkTcl*) cd; if (self == 0 || self->interp != ip) { Tcl_SetResult(ip, "Initialization error in dispatcher", TCL_STATIC); return TCL_ERROR; } return self->Execute(oc, ov); } MkTcl::MkTcl (MkWorkspace* ws_, Tcl_Interp* ip_, int id_, const char* cmd_) : Tcl (ip_), id (id_), work (*ws_) { Tcl_CreateObjCommand(ip_, (char*) cmd_, Dispatcher, this, 0); } MkTcl::~MkTcl () { } c4_View MkTcl::asView(Tcl_Obj* obj_) { SetCursorFromAny(interp, obj_); return AsPath(obj_)._view; } int& MkTcl::changeIndex(Tcl_Obj* obj_) { SetCursorFromAny(interp, obj_); Tcl_InvalidateStringRep(obj_); return AsIndex(obj_); } c4_RowRef MkTcl::asRowRef(Tcl_Obj* obj_, int type_) { c4_View view = asView(obj_); int index = AsIndex(obj_); int size = view.GetSize(); switch (type_) { case kExtendRow: if (index >= size) view.SetSize(size = index + 1); case kLimitRow: if (index > size) Fail("view index is too large"); else if (index < 0) Fail("view index is negative"); break; case kExistingRow: if (index < 0 || index >= size) { Fail("view index is out of range"); break; } case kAnyRow: ; } return view[index]; } int MkTcl::GetCmd() { c4_RowRef row = asRowRef(objv[1], kExistingRow); if (!_error) { const bool returnSize = objc > 2 && // fixed 1999-11-19 tcl_GetIndexFromObj(objv[2], getCmds) >= 0; if (returnSize) { --objc; ++objv; } else { _error = TCL_OK; // ignore missing option KeepRef o = Tcl_NewObj(); tcl_SetObjResult(o); } Tcl_Obj* result = tcl_GetObjResult(); if (objc < 3) { c4_View view = row.Container(); for (int i = 0; i < view.NumProperties() && !_error; ++i) { const c4_Property& prop = view.NthProperty(i); if (prop.Type() == 'V') continue; // omit subviews tcl_ListObjAppendElement(result, tcl_NewStringObj(prop.Name())); tcl_ListObjAppendElement(result, returnSize ? Tcl_NewIntObj(prop(row).GetSize()) : GetValue(row, prop)); } } else if (objc == 3) { const c4_Property& prop = AsProperty(objv[2], row.Container()); if (returnSize) Tcl_SetIntObj(result, prop(row).GetSize()); else GetValue(row, prop, result); } else { for (int i = 2; i < objc && !_error; ++i) { const c4_Property& prop = AsProperty(objv[i], row.Container()); tcl_ListObjAppendElement(result, returnSize ? Tcl_NewIntObj(prop(row).GetSize()) : GetValue(row, prop)); } } } return _error; } int MkTcl::SetValues(const c4_RowRef& row_, int objc, Tcl_Obj* const* objv) { while (objc >= 2 && !_error) { _error = SetAsObj(interp, row_, AsProperty(objv[0], row_.Container()), objv[1]); objc -= 2; objv += 2; } return _error; } int MkTcl::SetCmd() { if (objc < 4) return GetCmd(); int size = asView(objv[1]).GetSize(); c4_RowRef row = asRowRef(objv[1], kExtendRow); int e = SetValues(row, objc - 2, objv + 2); if (e != TCL_OK) asView(objv[1]).SetSize(size); // 1.1: restore old size on errors if (_error) return _error; return tcl_SetObjResult(objv[1]); } int MkTcl::RowCmd() { static const char* cmds [] = { "create", "append", "delete", "insert", "replace", 0 }; // "create" is optional if there are no further args int id = objc <= 1 ? 0 : tcl_GetIndexFromObj(objv[1], cmds); if (id < 0) return _error; switch (id) { case 0: { Tcl_Obj* var = AllocateNewTempRow(work); KeepRef keeper (var); SetValues(asRowRef(var, kExtendRow), objc - 2, objv + 2); return tcl_SetObjResult(var); // different result } case 1: { Tcl_Obj* var = Tcl_DuplicateObj(objv[2]); tcl_SetObjResult(var); // used to be a single stmt, avoids bug in gcc 2.7.2 on Linux? int size = asView(var).GetSize(); changeIndex(var) = size; int oc = objc - 3; Tcl_Obj** ov = (Tcl_Obj**) objv + 3; // 2003-03-16, allow giving all pairs as list if (oc == 1 && Tcl_ListObjGetElements(interp, objv[3], &oc, &ov) != TCL_OK) return TCL_ERROR; // 2000-06-15: this will not work with custom viewers which // take over ordering or uniqueness, because such views can // not be resized to create emtpy rows, which get filled in int e = SetValues(asRowRef(var, kExtendRow), oc, ov); if (e != TCL_OK) asView(var).SetSize(size); // 1.1: restore old size on errors return e; } case 2: { c4_RowRef row = asRowRef(objv[2]); if (_error) return _error; c4_View view = row.Container(); int index = AsIndex(objv[2]); int count = objc > 3 ? tcl_GetIntFromObj(objv[3]) : 1; if (count > view.GetSize() - index) count = view.GetSize() - index; if (count >= 1) { view.RemoveAt(index, count); work.Invalidate(AsPath(objv[2])); } } break; case 3: { c4_RowRef toRow = asRowRef(objv[2], kLimitRow); if (_error) return _error; c4_View view = toRow.Container(); int n = AsIndex(objv[2]); int count = objc > 3 ? tcl_GetIntFromObj(objv[3]) : 1; if (count >= 1) { c4_Row temp; view.InsertAt(n, temp, count); if (objc > 4) { c4_RowRef fromRow = asRowRef(objv[4]); if (_error) return _error; while (--count >= 0) view[n++] = fromRow; } work.Invalidate(AsPath(objv[2])); } } break; case 4: { c4_RowRef row = asRowRef(objv[2]); if (_error) return _error; if (objc > 3) row = asRowRef(objv[3]); else row = c4_Row (); } break; } if (_error) return _error; return tcl_SetObjResult(objv[2]); } int MkTcl::FileCmd() { static const char* cmds [] = { "open", "end", "close", "commit", "rollback", "load", "save", "views", "aside", "autocommit", "space", 0 }; int id = tcl_GetIndexFromObj(objv[1], cmds); if (id < 0) return _error; if (id == 0 && objc == 2) // new in 1.1: return list of db's { Tcl_Obj* result = tcl_GetObjResult(); // skip first entry, which is for temp rows for (int i = 1; i < work.NumItems() && !_error; ++i) { MkWorkspace::Item* ip = work.Nth(i); if (ip != 0) { tcl_ListObjAppendElement(result, tcl_NewStringObj(ip->_name)); tcl_ListObjAppendElement(result, tcl_NewStringObj(ip->_fileName)); } } return _error; } const char* string = Tcl_GetStringFromObj(objv[2], 0); MkWorkspace::Item* np = work.Find(f4_GetToken(string)); if (np == 0 && id > 1) return Fail("no storage with this name"); switch (id) { case 0: // open { if (np != 0) return Fail("file already open"); int mode = 1; bool nocommit = false, shared = false; static const char* options [] = { "-readonly", "-extend", "-nocommit", "-shared", 0 }; while (objc > 2 && *Tcl_GetStringFromObj(objv[objc-1], 0) == '-') switch (tcl_GetIndexFromObj(objv[--objc], options)) { case 0: mode = 0; break; case 1: mode = 2; break; case 2: nocommit = true; break; case 3: shared = true; break; default: return _error; } const char* name = Tcl_GetStringFromObj(objv[2], 0); int len = 0; const char* file = objc < 4 ? "" : Tcl_GetStringFromObj(objv[3], &len); Tcl_DString ds; const char *native = Tcl_UtfToExternalDString(NULL, file, len, &ds); np = work.Define(name, native, mode, shared); Tcl_DStringFree(&ds); if (np == 0) return Fail("file open failed"); if (*file && mode != 0 && !nocommit) np->_storage.AutoCommit(); } break; case 1: // end { int len; const char* name = Tcl_GetStringFromObj(objv[2], &len); Tcl_DString ds; const char *native = Tcl_UtfToExternalDString(NULL, name, len, &ds); c4_FileStrategy strat; int err = strat.DataOpen(native, false); Tcl_DStringFree(&ds); if (!err || !strat.IsValid()) return Fail("no such file"); t4_i32 end = strat.EndOfData(); if (end < 0) return Fail("not a Metakit datafile"); Tcl_SetIntObj(tcl_GetObjResult(), end); return _error; } break; case 2: // close { delete np; } break; case 3: // commit { if (!np->_storage.Strategy().IsValid()) return Fail("cannot commit temporary dataset"); np->ForceRefresh(); // detach first // 1-Mar-1999: check commit success bool full = objc > 3 && strcmp(Tcl_GetStringFromObj(objv[3], 0), "-full") == 0; if (!np->_storage.Commit(full)) return Fail("I/O error during commit"); } break; case 4: // rollback { if (!np->_storage.Strategy().IsValid()) return Fail("cannot rollback temporary dataset"); np->ForceRefresh(); // detach first bool full = objc > 3 && strcmp(Tcl_GetStringFromObj(objv[3], 0), "-full") == 0; np->_storage.Rollback(full); } break; case 5: // load { char* channel = Tcl_GetStringFromObj(objv[3], 0); int mode; Tcl_Channel cp = Tcl_GetChannel(interp, channel, &mode); if (cp == 0 || !(mode & TCL_READABLE)) return Fail("load from channel failed"); if (Tcl_SetChannelOption(interp, cp, "-translation", "binary")) return Fail(); np->ForceRefresh(); // detach first c4_TclStream stream (cp); if (!np->_storage.LoadFrom(stream)) return Fail("load error"); } break; case 6: // save { char* channel = Tcl_GetStringFromObj(objv[3], 0); int mode; Tcl_Channel cp = Tcl_GetChannel(interp, channel, &mode); if (cp == 0 || !(mode & TCL_WRITABLE)) return Fail("save to channel failed"); if (Tcl_SetChannelOption(interp, cp, "-translation", "binary")) return Fail(); c4_TclStream stream (cp); np->_storage.SaveTo(stream); } break; case 7: // views { c4_View view = np->_storage; Tcl_Obj* result = tcl_GetObjResult(); for (int i = 0; i < view.NumProperties() && !_error; ++i) { const c4_Property& prop = view.NthProperty(i); tcl_ListObjAppendElement(result, tcl_NewStringObj(prop.Name())); } return _error; // different result } case 8: // aside { if (objc != 4) return Fail("mk::file aside: needs 2 storage args"); const char* as = Tcl_GetStringFromObj(objv[3], 0); MkWorkspace::Item* np2 = work.Find(f4_GetToken(as)); if (np2 == 0) return Fail("no storage with this name"); np->_storage.SetAside(np2->_storage); } break; case 9: // autocommit { if (objc != 3) return Fail("mk::file autocommit: too many args"); np->_storage.AutoCommit(); } break; case 10: // space, new on 30-11-2001: returns allocator used space pairs { // nasty hack to obtain the storage's sequence pointer c4_View v = np->_storage; c4_Cursor c = &v[0]; c4_Sequence* s = c._seq; // even more horrible (i.e. brittle) hack to get the space vector c4_Persist* p = s->Persist(); c4_PtrArray* a = p != 0 ? *(c4_PtrArray**) p : 0; // first field if (a == 0) return Fail("storage is not persistent"); // now return the values as a list Tcl_Obj* r = tcl_GetObjResult(); for (int i = 1; i < a->GetSize() - 1 && !_error; ++i) tcl_ListObjAppendElement(r, Tcl_NewLongObj((long) a->GetAt(i))); return _error; } } if (_error) return _error; return tcl_SetObjResult(objv[2]); } int MkTcl::ViewCmd() { int id = tcl_GetIndexFromObj(objv[1], viewCmds); if (id < 0) return _error; switch (id) { case 0: // layout if (objc == 3) { const char* string = Tcl_GetStringFromObj(objv[2], 0); MkWorkspace::Item* np = work.Find(f4_GetToken(string)); if (np == 0) return Fail("no storage with this name"); c4_Storage& s = np->_storage; const char* p = s.Description(f4_GetToken(string)); if (p == 0) return Fail("no view with this name"); c4_String desc = KitToTclDesc(p); KeepRef o = tcl_NewStringObj(desc); return tcl_SetObjResult(o); // different result } // else fall through case 1: // delete { const char* string = Tcl_GetStringFromObj(objv[2], 0); MkWorkspace::Item* np = work.Find(f4_GetToken(string)); if (np == 0 && id != 4) return Fail("no storage with this name"); c4_String s = f4_GetToken(string); if (s.IsEmpty() || *string != 0) return Fail("unrecognized view name"); if (id == 0) { KeepRef o = tcl_NewStringObj(s); list2desc(objv[3], o); const char* desc = Tcl_GetStringFromObj(o, 0); if (desc && *desc) np->_storage.GetAs(desc); } else { c4_View v = np->_storage; if (v.FindPropIndexByName(s) < 0) return Fail("no view with this name"); np->_storage.GetAs(s); } np->ForceRefresh(); // make sure views are re-attached } break; case 2: // size { c4_View view = asView(objv[2]); if (objc > 3) { int i = tcl_GetIntFromObj(objv[3]); if (_error) return _error; view.SetSize(i); } Tcl_SetIntObj(tcl_GetObjResult(), view.GetSize()); return _error; // different result } break; case 3: // properties case 8: // info (will be deprecated) { c4_View view = asView(objv[2]); Tcl_Obj* result = tcl_GetObjResult(); for (int i = 0; i < view.NumProperties() && !_error; ++i) { const c4_Property& prop = view.NthProperty(i); c4_String s = prop.Name(); if (prop.Type() != 'S') { s += ":"; s += prop.Type(); } tcl_ListObjAppendElement(result, tcl_NewStringObj(s)); } return _error; } case 4: // locate { c4_View view = asView(objv[2]); bool force = strcmp(Tcl_GetStringFromObj(objv[3], 0), "-force") == 0; int k = force ? 4 : 3; if (k >= objc) return Fail("no key specified"); c4_Row key; for (int i = 0; k + i < objc; ++i) { const c4_Property& prop = view.NthProperty(i); _error = SetAsObj(interp, key, prop, objv[k+i]); if (_error) return _error; } int pos; if (view.Locate(key, &pos) == 0) if (force) view.InsertAt(pos, key); else return Fail("key not found"); Tcl_SetIntObj(tcl_GetObjResult(), pos); return _error; } case 5: // restrict { if (objc <= 5) return Fail("too few args"); c4_View view = asView(objv[2]); c4_View hview = asView(objv[3]); int nkeys = tcl_GetIntFromObj(objv[4]); view = view.Hash(hview, nkeys); c4_Row key; for (int i = 0; i+5 < objc; ++i) { const c4_Property& prop = view.NthProperty(i); _error = SetAsObj(interp, key, prop, objv[i+5]); if (_error) return _error; } int pos = 0; int count = view.GetSize(); int result = view.RestrictSearch(key, pos, count); Tcl_Obj* r = tcl_GetObjResult(); tcl_ListObjAppendElement(r, Tcl_NewIntObj(result)); tcl_ListObjAppendElement(r, Tcl_NewIntObj(pos)); tcl_ListObjAppendElement(r, Tcl_NewIntObj(count)); return _error; } case 6: // open { if (objc < 3 || objc > 4) return Fail("wrong number of args"); c4_View view = asView(objv[2]); const char* name = objc > 3 ? Tcl_GetStringFromObj(objv[3], 0) : ""; MkView* cmd = new MkView (interp, view, name); Tcl_SetStringObj(tcl_GetObjResult(), (char*) (const char*) cmd->CmdName(), -1); return _error; } case 7: // new ?name? { if (objc < 2 || objc > 3) return Fail("wrong number of args"); c4_View view; const char* name = objc > 3 ? Tcl_GetStringFromObj(objv[2], 0) : ""; MkView* cmd = new MkView (interp, view, name); Tcl_SetStringObj(tcl_GetObjResult(), (char*) (const char*) cmd->CmdName(), -1); return _error; } } if (_error) return _error; return tcl_SetObjResult(objv[2]); } int MkTcl::LoopCmd() { Tcl_Obj* value = objc >= 4 ? Tcl_ObjSetVar2(interp, objv [1], 0, objv [2], TCL_LEAVE_ERR_MSG) : Tcl_ObjGetVar2(interp, objv[1], 0, TCL_LEAVE_ERR_MSG); if (value == 0) return Fail(); // has to exist, can't be valid otherwise long first = objc >= 5 ? tcl_ExprLongObj (objv [3]) : 0; long limit = objc >= 6 ? tcl_ExprLongObj (objv [4]) : asView(value).GetSize(); long incr = objc >= 7 ? tcl_ExprLongObj (objv [5]) : 1; if (incr == 0) Fail("increment must be nonzero"); if (_error) return _error; Tcl_Obj* var = objv[1]; Tcl_Obj* cmd = objv[objc-1]; for (int i = first; ; i += incr) { if (Tcl_IsShared(value)) value = Tcl_DuplicateObj(value); changeIndex(value) = i; if (Tcl_ObjSetVar2(interp, var, 0, value, TCL_LEAVE_ERR_MSG) == 0) return Fail(); if (!(i < limit && incr > 0 || i > limit && incr < 0)) break; Tcl_MutexUnlock(&mkMutex); _error = Tcl_EvalObj(interp, cmd); Tcl_MutexLock(&mkMutex); if (_error == TCL_CONTINUE) _error = TCL_OK; if (_error) { if (_error == TCL_BREAK) _error = TCL_OK; else if (_error == TCL_ERROR) { char msg[100]; sprintf(msg, "\n (\"mk::loop\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } break; } } if (_error == TCL_OK) Tcl_ResetResult(interp); return _error; } int MkTcl::CursorCmd() { int id = tcl_GetIndexFromObj(objv[1], cursorCmds); if (id < 0) return _error; Tcl_Obj* name = objv[2]; Tcl_Obj* var = 0; if (id == 0) { var = objc < 4 ? AllocateNewTempRow(work) : objv[3]; // create expects a path --objc; // shift so the index will be picked up if present ++objv; } else // alter an existing cursor { var = Tcl_ObjGetVar2(interp, name, 0, TCL_LEAVE_ERR_MSG); if (var == 0) return Fail(); // has to exist, can't be valid otherwise } // about to modify, so make sure we are sole owners Tcl_Obj* original = 0; if (Tcl_IsShared(var)) { original = var; var = Tcl_DuplicateObj(var); } KeepRef keeper (var); c4_View view = asView(var); int value; if (objc <= 3) { if (id == 1) // position without value returns current value { Tcl_SetIntObj(tcl_GetObjResult(), AsIndex(var)); return _error; } value = id == 0 ? 0 : 1; // create defaults to 0, incr defaults to 1 } else if (Tcl_GetIntFromObj(interp, objv[3], &value) != TCL_OK) { const char* step = Tcl_GetStringFromObj(objv[3], 0); if (strcmp(step, "end") == 0) value = view.GetSize() - 1; else { if (original) Tcl_DecrRefCount(original); return Fail(); } } if (id < 2) changeIndex(var) = value; else changeIndex(var) += value; Tcl_Obj* result = Tcl_ObjSetVar2(interp, name, 0, var, TCL_LEAVE_ERR_MSG); if (result == 0) return Fail(); return tcl_SetObjResult(result); } int MkTcl::SelectCmd() { TclSelector sel (interp, asView(objv[1])); static const char* opts [] = { "-min", // 0 "-max", // 1 "-exact", // 2 "-glob", // 3 "-regexp", // 4 "-keyword", // 5 "-first", // 6 "-count", // 7 "-sort", // 8 "-rsort", // 9 "-globnc", // 10 0 }; while (objc >= 4) { objc -= 2; // gobble next two arguments objv += 2; // at this point, *objv is the next option, and objc >= 2 int id = -1; const char* p = Tcl_GetStringFromObj(*objv, 0); if (p && *p == '-') { id = tcl_GetIndexFromObj(*objv, opts); if (id < 0) return _error; } switch (id) { case -1: // prop value : case-insensitive match { _error = sel.AddCondition(-1, objv[0], objv[1]); } break; case 0: // -min prop value : property must be greater or equal to value case 1: // -max prop value : property must be less or equal to value case 2: // -exact prop value : exact case-sensitive match case 3: // -glob prop pattern : match "glob" expression wildcard case 4: // -regexp prop pattern : match specified regular expression case 5: // -keyword prop prefix : match keyword in given property case 10: // -globnc prop pattern : match "glob", but ignore case { if (objc < 3) return Fail("not enough arguments"); _error = sel.AddCondition(id, objv[1], objv[2]); --objc; // gobble a third argument ++objv; } break; case 6: // -first pos : searching starts at specified row index case 7: // -count num : return no more than this many results { int n = tcl_GetIntFromObj(objv[1]); if (_error) return _error; if (id == 6) sel._first = n; else sel._count = n; } break; case 8: // -sort prop : sort on one or more properties, ascending case 9: // -rsort prop : sort on one or more properties, descending { c4_View props = sel.GetAsProps(objv[1]); for (int i = 0; i < props.NumProperties(); ++i) { const c4_Property& prop = props.NthProperty(i); sel._sortProps.AddProperty(prop); if (id == 9) sel._sortRevProps.AddProperty(prop); } } break; } } if (_error) return _error; return sel.DoSelect(tcl_GetObjResult()); } int MkTcl::ChannelCmd() { c4_RowRef row = asRowRef(objv[1]); MkPath& path = AsPath(objv[1]); int index = AsIndex(objv[1]); if (_error) return _error; const c4_BytesProp& memo = (const c4_BytesProp&) AsProperty(objv[2], path._view); int id = objc < 4 ? 0 : tcl_GetIndexFromObj(objv[3], channelCmds); if (id < 0) return _error; const char* p = path._path; MkWorkspace::Item* ip = work.Find(f4_GetToken(p)); if (ip == 0) return Fail("no storage with this name"); if (id == 1) memo (row).SetData(c4_Bytes()); // truncate the existing contents int mode = id == 0 ? TCL_READABLE : id == 1 ? TCL_WRITABLE : TCL_READABLE | TCL_WRITABLE; MkChannel* mkChan = new MkChannel (ip->_storage, path._view, memo, index); d4_assert(mkChan != 0); static int mkChanSeq = 0; char buffer [10]; sprintf(buffer, "mk%d", ++mkChanSeq); mkChan->_watchMask = 0; mkChan->_validMask = mode; mkChan->_interp = interp; mkChan->_chan = Tcl_CreateChannel(&mkChannelType, buffer, (ClientData) mkChan, mode); if (id == 2) Tcl_Seek(mkChan->_chan, 0, SEEK_END); // Tcl_CreateEventSource(mkSetupProc, mkCheckProc, (ClientData)mkChan); Tcl_RegisterChannel(interp, mkChan->_chan); if (_error) return _error; KeepRef o = tcl_NewStringObj(buffer); return tcl_SetObjResult(o); } #if MKSQL class TclSQL : public MkSQL { public: TclSQL (Tcl_Interp* ip_, const c4_Storage& sp_) : _interp (ip_) { Connect(sp_); } int ExecCmd(int objc_, Tcl_Obj* const* objv_) { if (objc_ != 2) return TCL_ERROR; const char* statement = Tcl_GetStringFromObj(objv_[1], 0); c4_View v = Execute(statement); if (_error) { Tcl_SetResult(_interp, "execute failed", TCL_STATIC); return TCL_ERROR; } Tcl_Obj* list = Tcl_GetObjResult(_interp); for (int n = 0; n < v.GetSize(); ++n) { c4_RowRef row = v[n]; Tcl_Obj* result = Tcl_NewObj(); for (int i = 0; i < v.NumProperties(); ++i) { const c4_Property& prop = v.NthProperty(i); c4_String name = prop.Name(); if (prop.Type() == 'V') continue; // omit subviews Tcl_ListObjAppendElement(_interp, result, GetAsObj(row, prop)); } Tcl_ListObjAppendElement(_interp, list, result); } return TCL_OK; } static int DoCmd(ClientData cd_, Tcl_Interp* ip_, int oc_, Tcl_Obj* const* ov_) { TclSQL* sql = (TclSQL*) cd_; return sql->ExecCmd(oc_, ov_); } static void DelCmd(ClientData cd_) { delete (TclSQL*) cd_; } Tcl_Interp* _interp; }; int MkTcl::SqlAuxCmd() { const char* dbName = Tcl_GetStringFromObj(objv[1], 0); const char* cmdName = Tcl_GetStringFromObj(objv[2], 0); MkWorkspace::Item* np = work.Find(dbName); if (np == 0) return Fail("no storage with this name"); TclSQL* sql = new TclSQL (interp, np->_storage); if (sql == 0 || sql->_error) return Fail("connect failed"); Tcl_CreateObjCommand(interp, (char*) cmdName, TclSQL::DoCmd, sql, TclSQL::DelCmd); if (_error) return _error; KeepRef o = tcl_NewStringObj("abc"); return tcl_SetObjResult(o); } #endif int MkTcl::Execute(int oc, Tcl_Obj* const* ov) { struct CmdDef { int (MkTcl::*proc)(); int min; int max; const char* desc; }; static CmdDef defTab [] = { // the "&MkTcl::" stuff is required for Mac cwpro2 { &MkTcl::GetCmd, 2, 0, "get cursor ?prop ...?" }, { &MkTcl::SetCmd, 3, 0, "set cursor prop ?value prop value ...?" }, { &MkTcl::CursorCmd, 3, 5, "cursor option cursorname ?...?" }, { &MkTcl::RowCmd, 2, 0, "row option ?cursor ...?" }, { &MkTcl::ViewCmd, 2, 0, "view option view ?arg?" }, { &MkTcl::FileCmd, 2, 6, "file option ?tag ...?" }, { &MkTcl::LoopCmd, 3, 7, "loop cursor ?path first limit incr? {cmds}" }, { &MkTcl::SelectCmd, 2, 0, "select path ?...?" }, { &MkTcl::ChannelCmd, 3, 4, "channel path prop ?mode?" }, #if MKSQL { &MkTcl::SqlAuxCmd, 3, 3, "cmd db" }, #endif { 0, 0, 0, 0 }, }; _error = TCL_OK; CmdDef& cd = defTab[id]; objc = oc; objv = ov; if (oc < cd.min || (cd.max > 0 && oc > cd.max)) { msg = "wrong # args: should be \"mk::"; msg += cd.desc; msg += "\""; return Fail(msg); } Tcl_MutexLock(&mkMutex); int result = (this->*cd.proc)(); Tcl_MutexUnlock(&mkMutex); return result; } /////////////////////////////////////////////////////////////////////////////// void MkWorkspace::CleanupCommands() { for (int i = 0; i < _commands.GetSize(); ++i) delete (MkTcl*) _commands.GetAt(i); _commands.SetSize(0); } static void ExitProc(ClientData cd_) { delete (MkWorkspace*) cd_; } static void DelProc(ClientData cd_, Tcl_Interp* ip_) { // got here through assoc's delproc, don't trigger again on exit Tcl_DeleteExitHandler(ExitProc, cd_); ExitProc(cd_); } static int Mktcl_Cmds(Tcl_Interp* interp, bool /*safe*/) { if (!MyInitStubs(interp)) return TCL_ERROR; // Create workspace if not present. MkWorkspace* ws = (MkWorkspace*) Tcl_GetAssocData(interp, "mk4tcl", 0); if (ws == 0) { Tcl_RegisterObjType (&mkPropertyType); Tcl_RegisterObjType (&mkCursorType); ws = new MkWorkspace (interp); // add an association with delproc to catch "interp delete", // since that does not seem to trigger exitproc handling (!) Tcl_SetAssocData(interp, "mk4tcl", DelProc, ws); Tcl_CreateExitHandler(ExitProc, ws); } // this list must match the "CmdDef defTab []" above. static const char* cmds [] = { "get", "set", "cursor", "row", "view", "file", "loop", "select", "channel", #if MKSQL "Q", #endif 0 }; c4_String prefix = "mk::"; for (int i = 0; cmds[i]; ++i) ws->DefCmd(new MkTcl (ws, interp, i, prefix + cmds[i])); return Tcl_PkgProvide(interp, "Mk4tcl", "2.4.9.3"); } /////////////////////////////////////////////////////////////////////////////// // The proper way to load this extension is with "load mk4tcl.{so,dll} mk4tcl", // but 8.0.2 load guesses module "mk" instead of "mk4tcl" (it stops at digits) // when the third argument is omitted, allow that too: "load mk4tcl.{so,dll}". #if defined (__MWERKS__) #pragma export on #endif extern "C" DLLEXPORT int Mk4tcl_Init(Tcl_Interp* interp) { return Mktcl_Cmds(interp, false); } extern "C" DLLEXPORT int Mk_Init(Tcl_Interp* interp) { return Mktcl_Cmds(interp, false); } extern "C" DLLEXPORT int Mk4tcl_SafeInit(Tcl_Interp* interp) { return Mktcl_Cmds(interp, true); } extern "C" DLLEXPORT int Mk_SafeInit(Tcl_Interp* interp) { return Mktcl_Cmds(interp, true); } ///////////////////////////////////////////////////////////////////////////////