// mk4tcl.cpp -- // $Id: mk4tcl.cpp 4452 2008-12-10 22:57:54Z patthoyts $ // This is part of Metakit, see http://www.equi4.com/metakit.html #include "mk4tcl.h" #include "mk4io.h" #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 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 #define Tcl_GetErrorLine(interp) (interp)->errorLine #endif // definition of valid property name - alpha numerics, underscore, percent, // or any extended utf-8 character #define ISNAME(c) (isalnum((c)) || (c) == '_' || (c) == '%' || (c) & 0x80) /////////////////////////////////////////////////////////////////////////////// // 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; #ifdef TCL_THREADS // There is a single monolithic mutex for protecting all of Mk4tcl, but it has // to be a bit more advanced than Tcl's one since it has to support recursion, // i.e. re-entering this code from the *same* thread needs to be allowed. The // recursion can happen in Tcl's type callbacks, see "Tcl_ObjType mkCursorType". // // We know the current interpreter in all cases, it can be used as mutex owner. // So we can be multiple times inside the mutex, but ONLY from a simgle interp. // No deadlock is possible, locking is always in the order mkMutex -> infoMutex. TCL_DECLARE_MUTEX(mkMutex) // use a single monolithic mutex for now TCL_DECLARE_MUTEX(infoMutex) // use a second mutex to manage the info below // set to the interp holding the mutex, or to zero when not locked static Tcl_Interp *mutex_owner; // set to the reursion level, > 1 means we've re-entered from same interp static int mutex_level; static void EnterMutex(Tcl_Interp *ip_) { d4_assert(ip_ != 0); Tcl_MutexLock(&infoMutex); if (ip_ != mutex_owner) { Tcl_MutexUnlock(&infoMutex); Tcl_MutexLock(&mkMutex); Tcl_MutexLock(&infoMutex); d4_assert(mutex_owner == 0); mutex_owner = ip_; } ++mutex_level; Tcl_MutexUnlock(&infoMutex); } static void LeaveMutex() { Tcl_MutexLock(&infoMutex); d4_assert(mutex_owner != 0 && mutex_level > 0); if (--mutex_level == 0) { mutex_owner = 0; Tcl_MutexUnlock(&mkMutex); } Tcl_MutexUnlock(&infoMutex); } #else #define EnterMutex(x) #define LeaveMutex() #endif // put code in this file as a mutex is static in Windows int Mk_EvalObj(Tcl_Interp *ip_, Tcl_Obj *cmd_) { LeaveMutex(); int e = Tcl_EvalObj(ip_, cmd_); EnterMutex(ip_); 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 (ISNAME(*p) || *p == ':') ++p; c4_String result(str_, p - str_); if (*p) ++p; // advance over seperator - but no check! 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]); const char *limit = value_ + strlen(value_) - n; while (value_ <= limit) { 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 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_DeleteEvents(mkEventFilter, (ClientData)chan); chan->_chan = 0; 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, (char*)"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()) { ws_.AllocTempRow(_path); 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() { // 24-01-2003: paths should not clean up workspaces once exiting if (_currGen != -1) _ws->ForgetPath(this); } #if 0 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; } #endif 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 // 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; } void MkWorkspace::AllocTempRow(c4_String &result_) { 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); result_ = 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 (ISNAME(*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 = { (char*)"mkProperty", // name FreePropertyInternalRep, // freeIntRepProc DupPropertyInternalRep, // dupIntRepProc UpdateStringOfProperty, // updateStringProc SetPropertyFromAny // setFromAnyProc }; /////////////////////////////////////////////////////////////////////////////// const c4_Property &AsProperty(Tcl_Obj *objPtr, const c4_View &view_) { void *tag = (&view_[0])._seq; // horrific hack to get at c4_Sequence pointer if (objPtr->typePtr != &mkPropertyType || objPtr ->internalRep.twoPtrValue.ptr1 != tag) { CONST86 Tcl_ObjType *oldTypePtr = objPtr->typePtr; char type = 'S'; int length; char *string = Tcl_GetStringFromObj(objPtr, &length); c4_Property *prop; if (length > 2 && string[length - 2] == ':') { type = string[length - 1]; prop = new c4_Property(type, c4_String(string, length - 2)); } else { // look into the view to try to determine the type int n = view_.FindPropIndexByName(string); if (n >= 0) type = view_.NthProperty(n).Type(); prop = new c4_Property(type, string); } if (oldTypePtr && oldTypePtr->freeIntRepProc) oldTypePtr->freeIntRepProc(objPtr); objPtr->typePtr = &mkPropertyType; // use a (char*), because the Mac wants it, others use (void*) objPtr->internalRep.twoPtrValue.ptr1 = tag; objPtr->internalRep.twoPtrValue.ptr2 = (char*)prop; } return *(c4_Property*)objPtr->internalRep.twoPtrValue.ptr2; } static void FreePropertyInternalRep(Tcl_Obj *propPtr) { // no mutex protection needed here, MK's own C++ locking is sufficient delete (c4_Property*)propPtr->internalRep.twoPtrValue.ptr2; } /////////////////////////////////////////////////////////////////////////////// // // 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 = { (char*)"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) { MkPath &path = AsPath(cursorPtr); EnterMutex(path._ws->_interp); path.Refs( - 1); LeaveMutex(); } static void DupCursorInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { MkPath &path = AsPath(srcPtr); EnterMutex(path._ws->_interp); path.Refs( + 1); copyPtr->internalRep = srcPtr->internalRep; copyPtr->typePtr = &mkCursorType; LeaveMutex(); } int SetCursorFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { d4_assert(interp != 0); EnterMutex(interp); // 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) { CONST86 Tcl_ObjType *oldTypePtr = objPtr->typePtr; const char *string = Tcl_GetStringFromObj(objPtr, 0); // dig up the workspace used in this interpreter MkWorkspace *work = (MkWorkspace*)Tcl_GetAssocData(interp, "mk4tcl", 0); // cast required for Mac char *s = (char*)(void*)work->AddPath(string, interp); int i = isdigit(*string) ? atoi(string): - 1; if (oldTypePtr && oldTypePtr->freeIntRepProc) oldTypePtr->freeIntRepProc(objPtr); objPtr->typePtr = &mkCursorType; objPtr->internalRep.twoPtrValue.ptr1 = (void*)i; objPtr->internalRep.twoPtrValue.ptr2 = s; } LeaveMutex(); return TCL_OK; } static void UpdateStringOfCursor(Tcl_Obj *cursorPtr) { MkPath &path = AsPath(cursorPtr); EnterMutex(path._ws->_interp); c4_String s = path._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); LeaveMutex(); } 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, value_)); return TCL_OK; } bool TclSelector::MatchOneString(int id_, const char *value_, const char *crit_) { switch (id_) { case 2: // -exact prop value : exact case-sensitive match return strcmp(value_, crit_) == 0; case 3: // -glob prop pattern : match "glob" expression wildcard return Tcl_StringMatch(value_, crit_) > 0; case 4: // -regexp prop pattern : match specified regular expression return Tcl_RegExpMatch(_interp, (CONST84 char*)value_, (CONST84 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 c4_Row data; // this is *very* slow in Metakit 1.8 if (SetAsObj(_interp, data, prop, cond._crit) != 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); matched = MatchOneString(cond._id, Tcl_GetStringFromObj(_temp, NULL), Tcl_GetStringFromObj(cond._crit, NULL)); 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); SetAsObj(_interp, row_, prop, cond._crit); } } } } 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_, const 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, (char*)"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); #ifdef WIN32 np = work.Define(name, file, mode, shared); #else Tcl_DString ds; const char *native = Tcl_UtfToExternalDString(NULL, file, len, &ds); np = work.Define(name, native, mode, shared); Tcl_DStringFree(&ds); #endif 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); c4_FileStrategy strat; #ifdef WIN32 int err = strat.DataOpen(name, false); #else Tcl_DString ds; const char *native = Tcl_UtfToExternalDString(NULL, name, len, &ds); int err = strat.DataOpen(native, false); Tcl_DStringFree(&ds); #endif 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; LeaveMutex(); _error = Tcl_EvalObj(interp, cmd); EnterMutex(interp); 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)", Tcl_GetErrorLine(interp)); 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_RegisterChannel(interp, mkChan->_chan); if (_error) return _error; KeepRef o = tcl_NewStringObj(buffer); return tcl_SetObjResult(o); } int MkTcl::Execute(int oc, Tcl_Obj *const * ov) { struct CmdDef { int min; int max; const char *desc; }; static CmdDef defTab[] = { { 2, 0, "get cursor ?prop ...?" } , { 3, 0, "set cursor prop ?value prop value ...?" } , { 3, 5, "cursor option cursorname ?...?" } , { 2, 0, "row option ?cursor ...?" } , { 2, 0, "view option view ?arg?" } , { 2, 6, "file option ?tag ...?" } , { 3, 7, "loop cursor ?path first limit incr? {cmds}" } , { 2, 0, "select path ?...?" } , { 3, 4, "channel path prop ?mode?" } , { 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); } EnterMutex(interp); int result = 0; switch (id) { case 0: result = GetCmd(); break; case 1: result = SetCmd(); break; case 2: result = CursorCmd(); break; case 3: result = RowCmd(); break; case 4: result = ViewCmd(); break; case 5: result = FileCmd(); break; case 6: result = LoopCmd(); break; case 7: result = SelectCmd(); break; case 8: result = ChannelCmd(); break; } LeaveMutex(); 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 (Tcl_InitStubs(interp, "8.1", 0) == 0) 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", 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.7"); } /////////////////////////////////////////////////////////////////////////////// // 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}". EXTERN int Mk4tcl_Init(Tcl_Interp *interp) { return Mktcl_Cmds(interp, false); } EXTERN int Mk_Init(Tcl_Interp *interp) { return Mktcl_Cmds(interp, false); } EXTERN int Mk4tcl_SafeInit(Tcl_Interp *interp) { return Mktcl_Cmds(interp, true); } EXTERN int Mk_SafeInit(Tcl_Interp *interp) { return Mktcl_Cmds(interp, true); } ///////////////////////////////////////////////////////////////////////////////