Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
ocaml/maccaml/glue.c

511 lines
14 KiB
C
Raw Blame History

/***********************************************************************/
/* */
/* Objective Caml */
/* */
/* Damien Doligez, projet Para, INRIA Rocquencourt */
/* */
/* Copyright 1998 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* under the terms of the GNU Library General Public License. */
/* */
/***********************************************************************/
/* $Id$ */
#include <CursorCtl.h>
#include <fcntl.h>
#include <signal.h>
#include <stdlib.h>
#include "alloc.h"
#include "mlvalues.h"
#include "rotatecursor.h"
#include "signals.h"
#include "ui.h"
#include "main.h"
/* These are defined by the ocamlrun library. */
void caml_main(char **argv);
char *getcwd (char *buf, long size);
Handle macos_getfullpathname (short vrefnum, long dirid);
static int erroring = 0;
static long error_curpos;
static long error_anchor = -1;
/* This handle contains the environment variables. */
char *envPtr = NULL;
/* caml_at_work and Caml_working are used to manage the processor idle
state on PowerBooks (and also the beachball cursor: see AdjustCursor)
*/
int caml_at_work = 0;
/* Set caml_at_work to true or false. caml_at_work must always be
changed through this function, never directly. */
void Caml_working (int newstate)
{
if (gHasPowerManager){
if (caml_at_work && !newstate) EnableIdle ();
if (!caml_at_work && newstate) DisableIdle ();
}
caml_at_work = newstate;
}
/* Expand the percent escapes in the string specified by s.
The escapes are:
%a application file name
%d full pathname of the current working directory (ends in ':')
%t full pathname of the temporary directory (ends in ':')
%% %
*/
static OSErr expand_escapes (Handle s)
{
Size i, j, l;
OSErr err;
Handle curdir = NULL, tmpdir = NULL;
char *ptr2;
long len2;
l = GetHandleSize (s) - 1;
i = j = 0;
while (i < l){
if ((*s)[j] == '%'){
switch ((*s)[j+1]){
case 'a':
ptr2 = (char *) LMGetCurApName () + 1;
len2 = * (LMGetCurApName ());
break;
case 'd':
if (curdir == NULL) curdir = macos_getfullpathname (0, 0);
if (curdir == NULL){ err = fnfErr; goto failed; }
HLock (curdir);
ptr2 = *curdir;
len2 = GetHandleSize (curdir);
break;
case 't':
if (tmpdir == NULL){
short vrefnum;
long dirid;
err = FindFolder (kOnSystemDisk, kTemporaryFolderType, true,
&vrefnum, &dirid);
tmpdir = macos_getfullpathname (vrefnum, dirid);
if (tmpdir == NULL){ err = fnfErr; goto failed; }
}
HLock (tmpdir);
ptr2 = *tmpdir;
len2 = GetHandleSize (tmpdir);
break;
case '%':
ptr2 = "%";
len2 = 1;
break;
default:
ptr2 = "";
len2 = 0;
break;
}
Munger (s, j, NULL, 2, ptr2, len2);
j += len2 - 2;
i += 1;
}
++ i;
++ j;
}
if (curdir != NULL) DisposeHandle (curdir);
if (tmpdir != NULL) DisposeHandle (tmpdir);
return noErr;
failed:
if (curdir != NULL) DisposeHandle (curdir);
if (tmpdir != NULL) DisposeHandle (tmpdir);
return err;
}
/* [launch_caml_main] is called by [main].
It builds the command line according to the template found in
the 'Line'(kCommandLineTemplate) resource and the environment
variables according to the 'Line'(kEnvironmentTemplate).
Each of these resources is a sequence of strings separated by null
bytes. In each string, percent escapes are expanded (see above for
a description of percent escapes).
Each resource must end with a null byte.
*/
OSErr launch_caml_main (void)
{
Handle template = NULL;
Size len, i, j;
char *args = NULL;
int argc;
char **argv = NULL;
OSErr err;
template = GetResource ('Line', kCommandLineTemplate);
if (template == NULL){ err = ResError (); goto failed; }
err = expand_escapes (template); if (err != noErr) goto failed;
len = GetHandleSize (template);
args = malloc (len);
if (args == NULL){ err = memFullErr; goto failed; }
memcpy (args, *template, len);
argc = 0;
for (i = 0; i < len; i++){
if (args[i] == '\000') ++ argc;
}
argv = malloc ((argc+1) * sizeof (char *));
if (argv == NULL){ err = memFullErr; goto failed; }
i = j = 0;
do{
argv[j++] = args + i;
while (args [i] != '\000') ++ i;
++ i;
}while (i < len);
argv [argc] = NULL;
ReleaseResource (template);
template = GetResource ('Line', kEnvironmentTemplate);
if (template == NULL){ err = ResError (); goto failed; }
err = expand_escapes (template); if (err != noErr) goto failed;
len = GetHandleSize (template);
envPtr = NewPtr (len);
if (envPtr == NULL){ err = MemError (); goto failed; }
memcpy (envPtr, *template, len);
rotatecursor_options (&something_to_do, 50);
err = WinOpenToplevel ();
if (err != noErr) ExitApplication ();
Assert (!caml_at_work);
Caml_working (1);
caml_main (argv);
return noErr; /* Not reached */
failed:
if (template != NULL) ReleaseResource (template);
if (args != NULL) free (args);
if (argv != NULL) free (argv);
return err;
}
/***
ui_* stubs for I/O
*/
static void (**atexit_list) (void) = NULL;
static long atexit_size = 0;
static long atexit_len = 0;
void ui_exit (int return_code)
{
int i;
for (i = 0; i < atexit_len; i++) (*(atexit_list [i])) ();
Assert (caml_at_work);
Caml_working (0);
if (return_code != 0){
Str255 errorstr;
NumToString ((long) return_code, errorstr);
ParamText (errorstr, NULL, NULL, NULL);
modalkeys = kKeysOK;
InitCursor ();
NoteAlert (kAlertNonzeroExit, myModalFilterUPP);
}
while (1) GetAndProcessEvents (waitEvent, 0, 0);
}
int atexit (void (*f) (void))
{
if (atexit_list == NULL){
atexit_list = malloc (5 * sizeof (atexit_list [0]));
if (atexit_list == NULL) goto failed;
atexit_size = 5;
}else if (atexit_len >= atexit_size){
void *p = realloc (atexit_list, (atexit_size+10) * sizeof (atexit_list[0]));
if (p == NULL) goto failed;
atexit_list = p;
atexit_size += 10;
}
Assert (atexit_size > atexit_len);
atexit_list [atexit_len++] = f;
return 0;
failed:
/* errno = ENOMEM; est-ce que malloc positionne errno ? */
return -1;
}
int ui_read (int file_desc, char *buf, unsigned int length)
{
if (file_desc == 0){ /* Read from the toplevel window. */
long len, i;
char **htext;
WEReference we = WinGetWE (winToplevel);
long selstart, selend;
Boolean active;
short readonly, autoscroll;
int atend;
Assert (we != NULL);
htext = (char **) WEGetText (we);
Assert (caml_at_work);
Caml_working (0);
while (1){
char *p = *htext; /* The Handle is not locked. Be careful with p. */
len = WEGetTextLength (we);
for (i = wintopfrontier; i < len; i++){
if (p[i] == '\n') goto gotit;
}
GetAndProcessEvents (waitEvent, 0, 0);
}
gotit:
Assert (!caml_at_work);
Caml_working (1);
len = i+1 - wintopfrontier;
if (len > length) len = length;
memcpy (buf, (*htext)+wintopfrontier, len);
atend = ScrollAtEnd (winToplevel);
autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we);
WEFeatureFlag (weFAutoScroll, weBitClear, we);
WEGetSelection (&selstart, &selend, we);
readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
WEFeatureFlag (weFReadOnly, weBitClear, we);
/* Always set an empty selection before changing OutlineHilite. */
WESetSelection (wintopfrontier, wintopfrontier, we);
WEFeatureFlag (weFOutlineHilite, weBitClear, we);
active = WEIsActive (we);
if (active) WEDeactivate (we);
WESetSelection (wintopfrontier, wintopfrontier+len, we);
WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
&prefs.input, we);
WESetSelection (wintopfrontier, wintopfrontier, we);
if (active) WEActivate (we);
WEFeatureFlag (weFOutlineHilite, weBitSet, we);
WESetSelection (selstart, selend, we);
if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we);
AdjustScrollBars (winToplevel);
if (atend) ScrollToEnd (winToplevel);
WinAdvanceTopFrontier (len);
return len;
}else{
return read (file_desc, buf, length);
}
}
int ui_write (int file_desc, char *buf, unsigned int length)
{
if (file_desc == 1 || file_desc == 2){ /* Send to the toplevel window. */
long selstart, selend;
WEReference we = WinGetWE (winToplevel);
OSErr err;
short readonly, autoscroll;
int atend;
if (erroring){ /* overwrite mode to display errors; see terminfo_* */
error_curpos += length; Assert (error_curpos <= wintopfrontier);
return length;
}
Assert (we != NULL);
atend = ScrollAtEnd (winToplevel);
autoscroll = WEFeatureFlag (weFAutoScroll, weBitTest, we);
WEFeatureFlag (weFAutoScroll, weBitClear, we);
WEGetSelection (&selstart, &selend, we);
readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
WEFeatureFlag (weFReadOnly, weBitClear, we);
WESetSelection (wintopfrontier, wintopfrontier, we);
WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
&prefs.output, we);
err = WEInsert (buf, (SInt32) length, NULL, NULL, we);
if (err != noErr){
WESetSelection (selstart, selend, we);
/* XXX should set errno */
return -1;
}
if (selstart >= wintopfrontier){
selstart += length;
selend += length;
}else if (selend > wintopfrontier){
selend += length;
}
WESetSelection (selstart, selend, we);
if (autoscroll) WEFeatureFlag (weFAutoScroll, weBitSet, we);
AdjustScrollBars (winToplevel);
if (atend) ScrollToEnd (winToplevel);
WinAdvanceTopFrontier (length);
return length;
}else{
return write (file_desc, buf, length);
}
}
void ui_print_stderr (char *format, void *arg)
{
char buf [1000]; /* XXX fixed size buffer :-( */
sprintf (buf, format, arg); Assert (strlen (buf) < 1000);
ui_write (2, buf, strlen (buf));
}
/***
animated cursor (only when toplevel window is frontmost)
*/
typedef struct {
short nframes;
short current;
union {
CursHandle h;
struct { short id; short fill; } i;
} frames [1];
} **AnimCursHandle;
static AnimCursHandle acurh;
pascal void InitCursorCtl (acurHandle newCursors)
{
#pragma unused (newCursors)
long i;
acurh = (AnimCursHandle) GetResource ('acur', 0);
for (i = 0; i < (*acurh)->nframes; i++){
(*acurh)->frames[i].h = GetCursor ((*acurh)->frames[i].i.id);
if ((*acurh)->frames[i].h == NULL){
(*acurh)->frames[i].h = GetCursor (watchCursor);
Assert ((*acurh)->frames[i].h != NULL);
}
}
(*acurh)->current = 0;
}
/* In O'Caml, counter is always a multiple of 32. */
pascal void RotateCursor (long counter)
{
(*acurh)->current += (*acurh)->nframes + (counter >= 0 ? 1 : -1);
(*acurh)->current %= (*acurh)->nframes;
GetAndProcessEvents (noWait, 0, 0);
}
void DisplayRotatingCursor (void)
{
SetCursor (*((*acurh)->frames[(*acurh)->current].h));
}
/***
"getenv" in the standalone application
envPtr is set up by launch_caml_main
*/
char *getenv (const char *name)
{
Size envlen, i, namelen;
Assert (envPtr != NULL);
envlen = GetPtrSize (envPtr);
namelen = strlen (name);
i = 0;
do{
if (!strncmp (envPtr + i, name, namelen) && envPtr [i+namelen] == '='){
return envPtr + i + namelen + 1;
}
while (envPtr [i] != '\000') ++ i;
++ i;
}while (i < envlen);
return NULL;
}
/***
"terminfo" stuff: change the style of displayed text to show the
error locations. See also ui_write.
*/
value terminfo_setup (value vchan);
value terminfo_backup (value lines);
value terminfo_standout (value start);
value terminfo_resume (value lines);
#define Good_term_tag 0
value terminfo_setup (value vchan)
{
#pragma unused (vchan)
value result = alloc (1, Good_term_tag);
Field (result, 0) = Val_int (1000000000);
return result;
}
value terminfo_backup (value lines)
{
long i, j;
Handle txt;
char *p;
WEReference we = WinGetWE (winToplevel);
Assert (we != NULL);
txt = WEGetText (we);
p = (char *) *txt;
j = wintopfrontier - 1;
for (i = 0; i < Long_val (lines); i++){
Assert (p[j] == '\n');
do{ --j; }while (p[j] != '\n');
}
Assert (p[j] == '\n');
error_curpos = j + 1;
erroring = 1;
error_anchor = -1;
return Val_unit;
}
value terminfo_standout (value start)
{
if (Bool_val (start) && error_anchor == -1){
error_anchor = error_curpos;
}else if (!Bool_val (start) && error_anchor != -1){
long selstart, selend;
WEReference we = WinGetWE (winToplevel);
short readonly;
Assert (we != NULL);
WEGetSelection (&selstart, &selend, we);
readonly = WEFeatureFlag (weFReadOnly, weBitTest, we);
if (readonly) WEFeatureFlag (weFReadOnly, weBitClear, we);
WESetSelection (error_anchor, error_curpos, we);
WESetStyle (weDoFont + weDoFace + weDoSize + weDoColor + weDoReplaceFace,
&prefs.errors, we);
if (readonly) WEFeatureFlag (weFReadOnly, weBitSet, we);
WESetSelection (selstart, selend, we);
error_anchor = -1;
}
return Val_unit;
}
value terminfo_resume (value lines)
{
#pragma unused (lines)
erroring = 0;
return Val_unit;
}
Reference in New Issue View Git Blame Copy Permalink