word
pl_dde_poke(term_t handle, term_t item, term_t data, term_t timeout)
{ int hdl;
  char *datastr;
  HDDEDATA Hvalue;
  HSZ Hitem;
  long tmo;

  if ( !get_conv_handle(handle, &hdl) ||
       !get_hsz(item, &Hitem) )
    fail;
  if ( !PL_get_chars(data, &datastr, CVT_ALL) )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, data);
  if ( !PL_get_long(timeout, &tmo) )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, timeout);

  if ( tmo <= 0 )
    tmo = TIMEOUT_VERY_LONG;

  Hvalue = DdeClientTransaction(datastr, strlen(datastr)+1,
				conv_handle[hdl], Hitem, CF_TEXT,
				XTYP_POKE, (DWORD)tmo, NULL);

  if ( !Hvalue )
    return dde_warning("poke");

  succeed;
}
Beispiel #2
0
static int
win_shell(term_t op, term_t file, term_t how)
{ size_t lo, lf;
  wchar_t *o, *f;
  UINT h;
  HINSTANCE instance;

  if ( !PL_get_wchars(op,   &lo, &o, CVT_ALL|CVT_EXCEPTION|BUF_RING) ||
       !PL_get_wchars(file, &lf, &f, CVT_ALL|CVT_EXCEPTION|BUF_RING) ||
       !get_showCmd(how, &h) )
    fail;

  instance = ShellExecuteW(NULL, o, f, NULL, NULL, h);

  if ( (intptr_t)instance <= 32 )
  { const shell_error *se;

    for(se = se_errors; se->message; se++)
      { if ( se->eno == (int)(intptr_t)instance )
	return PL_error(NULL, 0, se->message, ERR_SHELL_FAILED, file);
    }
    PL_error(NULL, 0, NULL, ERR_SHELL_FAILED, file);
  }

  succeed;
}
static int
get_conv_handle(term_t handle, int *theh)
{ int h;

  if ( !PL_get_integer(handle, &h) || h < 0 || h >= MAX_CONVERSATIONS )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_dde_handle, handle);

  if ( !conv_handle[h] )
    return PL_error(NULL, 0, 0, ERR_EXISTENCE, ATOM_dde_handle, handle);

  *theh = h;
  succeed;
}
Beispiel #4
0
void *
PL_get_dbref(term_t t, db_ref_type *type_ptr)
{ void *data;
  PL_blob_t *type;

  if ( !PL_get_blob(t, &data, NULL, &type) )
  { error:
    PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_db_reference, t);
    return NULL;
  }

  if ( type == &clause_blob )
  { clref *ref = data;

    if ( false(ref->clause, CL_ERASED) )
    { *type_ptr = DB_REF_CLAUSE;
      return ref->clause;
    }
  } else if ( type == &record_blob )
  { recref *ref = data;

    if ( ref->record->record &&
	 false(ref->record->record, R_ERASED) )
    { *type_ptr = DB_REF_RECORD;
      return ref->record;
    }
  } else
  { goto error;
  }

  return NULL;
}
Beispiel #5
0
static int
dict_ordered(Word data, int count, int ex ARG_LD)
{ int ordered = TRUE;
  Word n1, n2;

  if ( count > 0 )
  { data++;			/* skip to key */
    deRef2(data, n1);
    if ( !is_key(*n1) )
      return -1;
  }

  for(; count > 1; count--, data += 2, n1=n2)
  { deRef2(data+2, n2);
    if ( !is_key(*n2) )
      return -1;
    if ( *n1 < *n2 )
      continue;
    if ( *n1 > *n2 )
      ordered = FALSE;
    if ( *n1 == *n2 )
    { if ( ex )
      { term_t t = PL_new_term_ref();
	*valTermRef(t) = linkVal(n1);
	PL_error(NULL, 0, NULL, ERR_DUPLICATE_KEY, t);
      }
      return -2;
    }
  }

  return ordered;
}
word
pl_open_dde_conversation(term_t service, term_t topic, term_t handle)
{ UINT i;
  HSZ Hservice, Htopic;

  if ( !dde_initialise() )
    fail;

  if ( !get_hsz(service, &Hservice) ||
       !get_hsz(topic, &Htopic) )
    fail;

  /* Establish a connection and get a handle for it */
  for (i=0; i < MAX_CONVERSATIONS; i++)   /* Find an open slot */
  { if (conv_handle[i] == (HCONV)NULL)
      break;
  }
  if (i == MAX_CONVERSATIONS)
    return PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_max_dde_handles);

  if ( !(conv_handle[i] = DdeConnect(ddeInst, Hservice, Htopic, 0)) )
    fail;

  DdeFreeStringHandle(ddeInst, Hservice);
  DdeFreeStringHandle(ddeInst, Htopic);

  return PL_unify_integer(handle, i);
}
Beispiel #7
0
static int
defOperator(Module m, atom_t name, int type, int priority, int force)
{ GET_LD
  Symbol s;
  operator *op;
  int t = (type & OP_MASK);		/* OP_PREFIX, ... */

  DEBUG(7, Sdprintf(":- op(%d, %s, %s) in module %s\n",
		    priority,
		    PL_atom_chars(operatorTypeToAtom(type)),
		    PL_atom_chars(name),
		    PL_atom_chars(m->name)));

  assert(t>=OP_PREFIX && t<=OP_POSTFIX);

  if ( !force && !SYSTEM_MODE )
  { if ( name == ATOM_comma ||
	 (name == ATOM_bar && ((t&OP_MASK) != OP_INFIX ||
			       (priority < 1001 && priority != 0))) )
    { GET_LD
      atom_t action = (name == ATOM_comma ? ATOM_modify : ATOM_create);
      term_t t = PL_new_term_ref();

      PL_put_atom(t, name);
      return PL_error(NULL, 0, NULL, ERR_PERMISSION,
		      action, ATOM_operator, t);
    }
  }


  LOCK();
  if ( !m->operators )
    m->operators = newOperatorTable(8);

  if ( (s = lookupHTable(m->operators, (void *)name)) )
  { op = s->value;
  } else if ( priority < 0 )
  { UNLOCK();				/* already inherited: do not change */
    return TRUE;
  } else
  { op = allocHeapOrHalt(sizeof(*op));

    op->priority[OP_PREFIX]  = -1;
    op->priority[OP_INFIX]   = -1;
    op->priority[OP_POSTFIX] = -1;
    op->type[OP_PREFIX]      = OP_INHERIT;
    op->type[OP_INFIX]       = OP_INHERIT;
    op->type[OP_POSTFIX]     = OP_INHERIT;
  }

  op->priority[t] = priority;
  op->type[t]     = (priority >= 0 ? type : OP_INHERIT);
  if ( !s )
  { PL_register_atom(name);
    addHTable(m->operators, (void *)name, op);
  }
  UNLOCK();

  return TRUE;
}
word
pl_convert_time(term_t time, term_t year, term_t month,
		term_t day, term_t hour, term_t minute,
		term_t second, term_t usec)
{ double tf;

  if ( PL_get_float(time, &tf) && tf <= PLMAXINT && tf >= PLMININT )
  { long t    = (long) tf;
    long us   = (long)((tf - (double) t) * 1000.0);
    struct tm *tm = LocalTime(&t);

    if ( PL_unify_integer(year,   tm->tm_year + 1900) &&
	 PL_unify_integer(month,  tm->tm_mon + 1) &&
	 PL_unify_integer(day,    tm->tm_mday) &&
	 PL_unify_integer(hour,   tm->tm_hour) &&
	 PL_unify_integer(minute, tm->tm_min) &&
	 PL_unify_integer(second, tm->tm_sec) &&
	 PL_unify_integer(usec,   us) )
      succeed;
    else
      fail;
  }

  return PL_error("convert_time", 8, NULL, ERR_TYPE, ATOM_time_stamp, time);
}
Beispiel #9
0
char *
DeRefLink(const	char *link, char *buf)
{ char tmp[MAXPATHLEN];
  char *f;
  int n = 20;				/* avoid loop! */

  while((f=DeRefLink1(link, tmp)) && n-- > 0)
    link = f;

  if ( n > 0 )
  { strcpy(buf, link);
    return buf;
  } else
  { GET_LD
    atom_t dom = PL_new_atom("dereference");
    atom_t typ = PL_new_atom("symlink");
    term_t t;
    int rc;

    rc = ( (t=PL_new_term_ref()) &&
	   PL_unify_chars(t, PL_ATOM|REP_FN, -1, link) &&
	   PL_error(NULL, 0, "too many (>20) levels of symbolic links",
		    ERR_PERMISSION, dom, typ, t) );
    (void)rc;
    PL_unregister_atom(dom);
    PL_unregister_atom(typ);

    return NULL;
  }
}
Beispiel #10
0
static int
bind_varnames(term_t varnames ARG_LD)
{
  CACHE_REGS
  Term t = Yap_GetFromSlot(varnames);
  while(!IsVarTerm(t) && IsPairTerm(t)) {
    Term tl = HeadOfTerm(t);
    Functor f;
    Term tv, t2, t1;

    if (!IsApplTerm(tl)) return FALSE;
    if ((f = FunctorOfTerm(tl)) != FunctorEq) {
      return FALSE;
    }
    t1 = ArgOfTerm(1, tl);
    if (IsVarTerm(t1)) {
      return PL_error(NULL, 0, "variable_names", ERR_INSTANTIATION, 0, t1);
    }
    t2 = ArgOfTerm(2, tl);
    tv = Yap_MkApplTerm(LOCAL_FunctorVar, 1, &t1);
    if (IsVarTerm(t2)) {
      Bind_and_Trail(VarOfTerm(t2), tv);
    }
    t = TailOfTerm(t);
  }
  return TRUE;
}
Beispiel #11
0
int
PL_existence_error(const char *type, term_t actual)
{ atom_t a = PL_new_atom(type);
  int rc = PL_error(NULL, 0, NULL, ERR_EXISTENCE, a, actual);
  PL_unregister_atom(a);

  return rc;
}
Beispiel #12
0
int
PL_domain_error(const char *expected, term_t actual)
{ atom_t a = PL_new_atom(expected);
  int rc = PL_error(NULL, 0, NULL, ERR_DOMAIN, a, actual);
  PL_unregister_atom(a);

  return rc;
}
Beispiel #13
0
int
PL_representation_error(const char *representation)
{ atom_t r = PL_new_atom(representation);
  int rc = PL_error(NULL, 0, NULL, ERR_REPRESENTATION, r);
  PL_unregister_atom(r);

  return rc;
}
Beispiel #14
0
int
PL_resource_error(const char *resource)
{ atom_t r = PL_new_atom(resource);
  int rc = PL_error(NULL, 0, NULL, ERR_RESOURCE, r);

  PL_unregister_atom(r);

  return rc;
}
Beispiel #15
0
int
PL_permission_error(const char *op, const char *type, term_t obj)
{ atom_t t = PL_new_atom(type);
  atom_t o = PL_new_atom(op);
  int rc = PL_error(NULL, 0, NULL, ERR_PERMISSION, o, t, obj);

  PL_unregister_atom(t);
  PL_unregister_atom(o);

  return rc;
}
Beispiel #16
0
static int
prolog_debug(term_t t, int flag)
{ char *topic;

  /* FIXME: handle lists */
  if ( !PL_get_chars(t, &topic, CVT_ATOM|CVT_STRING|CVT_EXCEPTION) )
    fail;

  if ( prolog_debug_topic(topic, flag) )
    return TRUE;

  return PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_debug_topic, t);
}
static int
get_hsz(term_t data, HSZ *rval)
{ char *s;

  if ( PL_get_chars(data, &s, CVT_ALL) )
  { HSZ h = DdeCreateStringHandle(ddeInst, s, CP_WINANSI);
    if ( h )
    { *rval = h;
      succeed;
    }
  }

  return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_text, data);
}
static int
allocServerHandle(HCONV handle)
{ int i;

  for(i=0; i<MAX_CONVERSATIONS; i++)
  { if ( !server_handle[i] )
    { server_handle[i] = handle;
      return i;
    }
  }

  PL_error(NULL, 0, NULL, ERR_RESOURCE, ATOM_max_dde_handles);

  return -1;
}
Beispiel #19
0
int
PL_get_clref(term_t t, Clause *cl)
{ struct clref *ref;
  PL_blob_t *type;

  if ( !PL_get_blob(t, (void**)&ref, NULL, &type) ||
       type != &clause_blob )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_db_reference, t);

  *cl = ref->clause;

  if ( true(ref->clause, CL_ERASED) )
    return -1;

  return TRUE;
}
Beispiel #20
0
int
PL_get_recref(term_t t, RecordRef *rec)
{ struct recref *ref;
  PL_blob_t *type;

  if ( !PL_get_blob(t, (void**)&ref, NULL, &type) ||
       type != &record_blob )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_db_reference, t);

  if ( ref->record->record &&
       false(ref->record->record, R_ERASED) )
  { *rec = ref->record;
    return TRUE;
  }

  return FALSE;
}
word
pl_dwim_predicate(term_t pred, term_t dwim, word h)
{ functor_t fdef;
  Module module = (Module) NULL;
  Procedure proc;
  Symbol symb;
  term_t head = PL_new_term_ref();
  TableEnum e;

  if ( ForeignControl(h) == FRG_CUTTED )
  { e = ForeignContextPtr(h);
    freeTableEnum(e);
    succeed;
  }

  if ( !PL_strip_module(pred, &module, head) )
    fail;
  if ( !PL_get_functor(head, &fdef) )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_callable, head);
  	
  if ( ForeignControl(h) == FRG_FIRST_CALL )
    e = newTableEnum(module->procedures);
  else
    e = ForeignContextPtr(h);

  while( (symb = advanceTableEnum(e)) )
  { Definition def;
    char *name;

    proc = symb->value;
    def  = proc->definition;
    name = stringAtom(def->functor->name);

    if ( dwimMatch(stringAtom(nameFunctor(fdef)), name) &&
         isDefinedProcedure(proc) &&
         (name[0] != '$' || SYSTEM_MODE) )
    { if ( !PL_unify_functor(dwim, def->functor->functor) )
	continue;

      ForeignRedoPtr(e);
    }
  }

  freeTableEnum(e);
  fail;
}
word
pl_dde_request(term_t handle, term_t item,
	       term_t value, term_t timeout)
{ int hdl;
  int rval;
  int ddeErr;
  HSZ Hitem;
  DWORD result, valuelen;
  HDDEDATA Hvalue;
  long tmo;

  if ( !get_conv_handle(handle, &hdl) ||
       !get_hsz(item, &Hitem) )
    fail;
  if ( !PL_get_long(timeout, &tmo) )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, timeout);

  if ( tmo <= 0 )
    tmo = TIMEOUT_VERY_LONG;

  Hvalue = DdeClientTransaction(NULL, 0, conv_handle[hdl], Hitem, CF_TEXT,
				XTYP_REQUEST, (DWORD)tmo, &result);
  ddeErr = DdeGetLastError(ddeInst);
  DdeFreeStringHandle(ddeInst, Hitem);

  if ( Hvalue)
  { char * valuebuf;
    char * valuedata;
    valuedata = DdeAccessData(Hvalue, &valuelen);
    valuebuf = (char *)malloc((size_t)valuelen+1);
    strncpy(valuebuf, valuedata, valuelen+1);
    DdeUnaccessData(Hvalue);
    valuebuf[valuelen] = EOS;
    rval = PL_unify_string_chars(value, valuebuf);
    free(valuebuf);
    return rval;
  } else
  { const char * errmsg = dde_error_message(ddeErr);

    return PL_unify_term(value,
			 PL_FUNCTOR, FUNCTOR_error1, /* error(Message) */
			 PL_CHARS,   errmsg);
  }
}
Beispiel #23
0
static int
globalMPZ(Word at, mpz_t mpz, int flags ARG_LD)
{ DEBUG(CHK_SECURE, assert(!onStackArea(global, at) && !onStackArea(local, at)));

  if ( mpz->_mp_alloc )
  { Word p;
    size_t size;
    size_t wsz = mpz_wsize(mpz, &size);
    word m     = mkIndHdr(wsz+1, TAG_INTEGER);

    if ( wsizeofInd(m) != wsz+1 )
    { PL_error(NULL, 0, NULL, ERR_REPRESENTATION, ATOM_integer);
      return 0;
    }

    if ( !hasGlobalSpace(wsz+3) )
    { int rc = ensureGlobalSpace(wsz+3, flags);

      if ( rc != TRUE )
	return rc;
    }
    p = gTop;
    gTop += wsz+3;

    *at = consPtr(p, TAG_INTEGER|STG_GLOBAL);

    *p++     = m;
    p[wsz]   = 0L;			/* pad out */
    p[wsz+1] = m;
    *p++     = (word)mpz->_mp_size;
    memcpy(p, mpz->_mp_d, size);
  } else				/* already on the stack */
  { Word p = (Word)mpz->_mp_d - 2;
#ifndef NDEBUG
    size_t size;
    size_t wsz = mpz_wsize(mpz, &size);
    assert(p[0] == mkIndHdr(wsz+1, TAG_INTEGER));
#endif
    *at = consPtr(p, TAG_INTEGER|STG_GLOBAL);
  }

  return TRUE;
}
Beispiel #24
0
static int
win_exec(size_t len, const wchar_t *cmd, UINT show)
{ GET_LD
  STARTUPINFOW startup;
  PROCESS_INFORMATION info;
  int rval;
  wchar_t *wcmd;

  memset(&startup, 0, sizeof(startup));
  startup.cb = sizeof(startup);
  startup.wShowWindow = show;

					/* ensure 0-terminated */
  wcmd = PL_malloc((len+1)*sizeof(wchar_t));
  memcpy(wcmd, cmd, len*sizeof(wchar_t));
  wcmd[len] = 0;

  rval = CreateProcessW(NULL,		/* app */
			wcmd,
			NULL, NULL,	/* security */
			FALSE,		/* inherit handles */
			0,		/* flags */
			NULL,		/* environment */
			NULL,		/* Directory */
			&startup,
			&info);		/* process info */
  PL_free(wcmd);

  if ( rval )
  { CloseHandle(info.hProcess);
    CloseHandle(info.hThread);

    succeed;
  } else
  { term_t tmp = PL_new_term_ref();

    return ( PL_unify_wchars(tmp, PL_ATOM, len, cmd) &&
	     PL_error(NULL, 0, WinError(), ERR_SHELL_FAILED, tmp)
	   );
  }
}
Beispiel #25
0
int
raiseStackOverflow(int overflow)
{ GET_LD
  Stack s;

  switch(overflow)
  { case LOCAL_OVERFLOW:    s = (Stack)&LD->stacks.local;    break;
    case GLOBAL_OVERFLOW:   s = (Stack)&LD->stacks.global;   break;
    case TRAIL_OVERFLOW:    s = (Stack)&LD->stacks.trail;    break;
    case ARGUMENT_OVERFLOW: s = (Stack)&LD->stacks.argument; break;
    case MEMORY_OVERFLOW:
      return PL_error(NULL, 0, NULL, ERR_NOMEM);
    case FALSE:				/* some other error is pending */
      return FALSE;
    default:
      s = NULL;
      assert(0);
  }

  return outOfStack(s, STACK_OVERFLOW_RAISE);
}
Beispiel #26
0
static int
get_showCmd(term_t show, UINT *cmd)
{ char *s;
  showtype *st;
  static showtype types[] =
  { { "hide",		 SW_HIDE },
    { "maximize",	 SW_MAXIMIZE },
    { "minimize",	 SW_MINIMIZE },
    { "restore",	 SW_RESTORE },
    { "show",		 SW_SHOW },
    { "showdefault",	 SW_SHOWDEFAULT },
    { "showmaximized",   SW_SHOWMAXIMIZED },
    { "showminimized",   SW_SHOWMINIMIZED },
    { "showminnoactive", SW_SHOWMINNOACTIVE },
    { "showna",          SW_SHOWNA },
    { "shownoactive",    SW_SHOWNOACTIVATE },
    { "shownormal",      SW_SHOWNORMAL },
					/* compatibility */
    { "normal",		 SW_SHOWNORMAL },
    { "iconic",		 SW_MINIMIZE },
    { NULL, 0 },
  };

  if ( show == 0 )
  { *cmd = SW_SHOWNORMAL;
    succeed;
  }

  if ( !PL_get_chars(show, &s, CVT_ATOM|CVT_EXCEPTION) )
    fail;
  for(st=types; st->name; st++)
  { if ( streq(st->name, s) )
    { *cmd = st->id;
      succeed;
    }
  }

  return PL_error(NULL, 0, NULL, ERR_DOMAIN,
		  PL_new_atom("win_show"), show);
}
Beispiel #27
0
static int
get_hsz(DWORD ddeInst, term_t data, HSZ *rval)
{ wchar_t *s;
  size_t len;

  if ( PL_get_wchars(data, &len, &s, CVT_ALL|CVT_EXCEPTION) )
  { HSZ h;

    assert(s[len] == 0);			/* Must be 0-terminated */

    DEBUG(2, Sdprintf("Get HSZ for %Ws ...\n", s));
    if ( (h=DdeCreateStringHandleW(ddeInst, s, CP_WINUNICODE)) )
    { DEBUG(2, Sdprintf("\tHSZ = %p\n", h));
      *rval = h;
      succeed;
    }

    return PL_error(NULL, 0, WinError(), ERR_SYSCALL, "DdeCreateStringHandleW");
  }

  fail;
}
word
pl_convert_time2(term_t time, term_t string)
{ double tf;

  if ( PL_get_float(time, &tf) && tf <= PLMAXINT && tf >= PLMININT )
  { time_t t  = (time_t)(long)tf;
    char *s = ctime(&t);

    if ( s )
    { char *e = s + strlen(s);
      while(e>s && e[-1] == '\n')
	e--;
      *e = EOS;

      return PL_unify_string_chars(string, s);
    }

    return warning("convert_time/2: %s", OsError());
  }
  
  return PL_error("convert_time", 2, NULL, ERR_TYPE, ATOM_time_stamp, time);
}
word
pl_getenv(term_t var, term_t value)
{ char *n;

  if ( PL_get_chars(var, &n, CVT_ALL) )
  { int len = getenvl(n);

    if ( len >= 0 )
    { char *buf	= alloca(len+1);
      
      if ( buf )
      { char *s;

	if ( (s=getenv3(n, buf, len+1)) )
	  return PL_unify_atom_chars(value, s);
      } else
	return PL_error("getenv", 2, NULL, ERR_NOMEM);
    }

    fail;
  }

  return warning("getenv/2: instantiation fault");
}  
word
pl_dde_register_service(term_t topic, term_t onoff)
{ HSZ t;
  int a;

  TRY(dde_initialise());

  if ( !get_hsz(topic, &t) )
    fail;
  if ( !PL_get_bool(onoff, &a) )
    return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_bool, onoff);

  if ( !a )
  { int rval = (int)DdeNameService(ddeInst, t, 0L, DNS_UNREGISTER);
    DdeFreeStringHandle(ddeInst, t);
    return rval ? TRUE : FALSE;
  } else
  { if ( DdeNameService(ddeInst, t, 0L, DNS_REGISTER|DNS_FILTERON) )
      succeed;				/* should we free too? */

    DdeFreeStringHandle(ddeInst, t);
    return dde_warning("register_request");
  }
}