gsl-shell.c - gsl-shell.git - gsl-shell

/* 
 * GSL shell interactive interface to GSL library
 * Based on LUA stand-alone interpreter
 *
 * Copyright (C) 2009 Francesco Abbate
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or (at
 * your option) any later version.
 * 
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 * General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
** Lua stand-alone interpreter
** Lua - An Extensible Extension Language
** Lua.org, PUC-Rio, Brazil (http://www.lua.org)
******************************************************************************
* Copyright (C) 1994-2008 Lua.org, PUC-Rio. All rights reserved.
*
* Permission is hereby granted, free of charge, to any person obtaining
* a copy of this software and associated documentation files (the
* "Software"), to deal in the Software without restriction, including
* without limitation the rights to use, copy, modify, merge, publish,
* distribute, sublicense, and/or sell copies of the Software, and to
* permit persons to whom the Software is furnished to do so, subject to
* the following conditions:
*
* The above copyright notice and this permission notice shall be
* included in all copies or substantial portions of the Software.
*
* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
* IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
* CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
* TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
* SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
******************************************************************************/
#include <signal.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <pthread.h>
#define lua_c
#include "lua.h"
#include <lauxlib.h>
#include <lualib.h>
#include "llimits.h"
#include "gsl-shell.h"
#include "lua-gsl.h"
#include "lua-utils.h"
#include "object-index.h"
#include "canvas-window.h"
#define report error_report
struct window_unref_cell {
 int id;
 struct window_unref_cell *next;
};
#define UNREF_FIXED_SIZE 8
static int unref_fixed_list[UNREF_FIXED_SIZE];
static size_t unref_fixed_count = 0;
static struct window_unref_cell *window_unref_list = NULL;
static lua_State *globalL = NULL;
static const char *progname = LUA_PROGNAME;
extern int luaopen_gsl (lua_State *L);
static const luaL_Reg gshlibs[] = {
 {"", luaopen_base},
 {LUA_LOADLIBNAME, luaopen_package},
 {LUA_TABLIBNAME, luaopen_table},
 {LUA_IOLIBNAME, luaopen_io},
 {LUA_OSLIBNAME, luaopen_os},
 {LUA_STRLIBNAME, luaopen_string},
#if 0
 {LUA_MATHLIBNAME, luaopen_math},
 {LUA_DBLIBNAME, luaopen_debug},
 {MLUA_GSLLIBNAME, luaopen_gsl},
#endif
 {NULL, NULL}
};
pthread_mutex_t gsl_shell_mutex[1];
static void lstop (lua_State *L, lua_Debug *ar) {
 (void)ar; /* unused arg. */
 lua_sethook(L, NULL, 0, 0);
 luaL_error(L, "interrupted!");
}
static void laction (int i) {
 signal(i, SIG_DFL); /* if another SIGINT happens before lstop,
 terminate process (default action) */
 lua_sethook(globalL, lstop, LUA_MASKCALL | LUA_MASKRET | LUA_MASKCOUNT, 1);
}
static void print_usage (void) {
 fprintf(stderr,
 "usage: %s [options] [script [args]].\n"
 "Available options are:\n"
 " -e stat execute string " LUA_QL("stat") "\n"
 " -l name require library " LUA_QL("name") "\n"
 " -i enter interactive mode after executing " LUA_QL("script") "\n"
 " -v show version information\n"
 " -- stop handling options\n"
 " - execute stdin and stop handling options\n"
 ,
 progname);
 fflush(stderr);
}
void
gsl_shell_openlibs (lua_State *L) 
{
 const luaL_Reg *lib = gshlibs;
 for (; lib->func; lib++) 
 {
 lua_pushcfunction(L, lib->func);
 lua_pushstring(L, lib->name);
 lua_call(L, 1, 0);
 }
 lua_pushvalue (L, LUA_GLOBALSINDEX); /* open math in global scope */
 lua_setglobal (L, LUA_MATHLIBNAME);
 luaopen_math (L);
 lua_pop (L, 1);
 lua_pushnil (L); /* remove math */
 lua_setglobal (L, LUA_MATHLIBNAME);
 lua_pushvalue (L, LUA_GLOBALSINDEX); /* open gsl in global scope */
 lua_setglobal (L, MLUA_GSLLIBNAME);
 luaopen_gsl (L);
 lua_pop (L, 1);
 lua_pushnil (L); /* remove gsl */
 lua_setglobal (L, MLUA_GSLLIBNAME);
}
static void l_message (const char *pname, const char *msg) {
 if (pname) fprintf(stderr, "%s: ", pname);
 fprintf(stderr, "%s\n", msg);
 fflush(stderr);
}
int error_report (lua_State *L, int status) {
 if (status && !lua_isnil(L, -1)) {
 const char *msg = lua_tostring(L, -1);
 if (msg == NULL) msg = "(error object is not a string)";
 l_message(progname, msg);
 lua_pop(L, 1);
 }
 return status;
}
static int traceback (lua_State *L) {
 if (!lua_isstring(L, 1)) /* 'message' not a string? */
 return 1; /* keep it intact */
 lua_getfield(L, LUA_GLOBALSINDEX, "debug");
 if (!lua_istable(L, -1)) {
 lua_pop(L, 1);
 return 1;
 }
 lua_getfield(L, -1, "traceback");
 if (!lua_isfunction(L, -1)) {
 lua_pop(L, 2);
 return 1;
 }
 lua_pushvalue(L, 1); /* pass error message */
 lua_pushinteger(L, 2); /* skip this function and traceback */
 lua_call(L, 2, 1); /* call debug.traceback */
 return 1;
}
static int docall (lua_State *L, int narg, int clear) {
 int status;
 int base = lua_gettop(L) - narg; /* function index */
 lua_pushcfunction(L, traceback); /* push traceback function */
 lua_insert(L, base); /* put it under chunk and args */
 signal(SIGINT, laction);
 status = lua_pcall(L, narg, (clear ? 0 : LUA_MULTRET), base);
 signal(SIGINT, SIG_DFL);
 lua_remove(L, base); /* remove traceback function */
 /* force a complete garbage collection in case of errors */
 if (status != 0) lua_gc(L, LUA_GCCOLLECT, 0);
 return status;
}
static void print_version (void) {
 l_message(NULL, "GSL Shell, Copyright (C) 2009, 2010 Francesco Abbate");
 l_message(NULL, "GNU Scientific Library, Copyright (C) The GSL Team");
 l_message(NULL, LUA_RELEASE ", " LUA_COPYRIGHT);
}
static int getargs (lua_State *L, char **argv, int n) {
 int narg;
 int i;
 int argc = 0;
 while (argv[argc]) argc++; /* count total number of arguments */
 narg = argc - (n + 1); /* number of arguments to the script */
 luaL_checkstack(L, narg + 3, "too many arguments to script");
 for (i=n+1; i < argc; i++)
 lua_pushstring(L, argv[i]);
 lua_createtable(L, narg, n + 1);
 for (i=0; i < argc; i++) {
 lua_pushstring(L, argv[i]);
 lua_rawseti(L, -2, i - n);
 }
 return narg;
}
static int dofile (lua_State *L, const char *name) {
 int status = luaL_loadfile(L, name) || docall(L, 0, 1);
 return report(L, status);
}
static int dostring (lua_State *L, const char *s, const char *name) {
 int status = luaL_loadbuffer(L, s, strlen(s), name) || docall(L, 0, 1);
 return report(L, status);
}
static int dolibrary (lua_State *L, const char *name) {
 lua_getglobal(L, "require");
 lua_pushstring(L, name);
 return report(L, docall(L, 1, 1));
}
static const char *get_prompt (lua_State *L, int firstline) {
 const char *p;
 lua_getfield(L, LUA_GLOBALSINDEX, firstline ? "_PROMPT" : "_PROMPT2");
 p = lua_tostring(L, -1);
 if (p == NULL) p = (firstline ? LUA_PROMPT : LUA_PROMPT2);
 lua_pop(L, 1); /* remove global */
 return p;
}
static int incomplete (lua_State *L, int status) {
 if (status == LUA_ERRSYNTAX) {
 size_t lmsg;
 const char *msg = lua_tolstring(L, -1, &lmsg);
 const char *tp = msg + lmsg - (sizeof(LUA_QL("<eof>")) - 1);
 if (strstr(msg, LUA_QL("<eof>")) == tp) {
 lua_pop(L, 1);
 return 1;
 }
 }
 return 0; /* else... */
}
static int pushline (lua_State *L, int firstline) {
 char buffer[LUA_MAXINPUT];
 char *b = buffer;
 size_t l;
 const char *prmt = get_prompt(L, firstline);
 if (lua_readline(L, b, prmt) == 0)
 {
 return 0; /* no input */
 }
 l = strlen(b);
 if (l > 0 && b[l-1] == '\n') /* line ends with newline? */
 b[l-1] = '0円'; /* remove it */
 lua_pushstring(L, b);
 lua_freeline(L, b);
 return 1;
}
static int loadline (lua_State *L) {
 int status;
 lua_settop(L, 0);
 if (!pushline(L, 1))
 return -1; /* no input */
#warning DEBUG CODE
 if (strcmp (lua_tostring(L, 1), "exit") == 0)
 return -1;
 lua_pushfstring(L, "return %s", lua_tostring(L, 1));
 status = luaL_loadbuffer(L, lua_tostring(L, 2), lua_strlen(L, 2), "=stdin");
 if (status == 0)
 {
 lua_saveline(L, 1);
 lua_replace (L, 1);
 lua_settop (L, 1);
 return 0;
 }
 lua_settop (L, 1);
 for (;;) { /* repeat until gets a complete line */
 status = luaL_loadbuffer(L, lua_tostring(L, 1), lua_strlen(L, 1), "=stdin");
 if (!incomplete(L, status)) break; /* cannot try to add lines? */
 if (!pushline(L, 0)) /* no more input? */
 return -1;
 lua_pushliteral(L, "\n"); /* add a new line... */
 lua_insert(L, -2); /* ...between the two lines */
 lua_concat(L, 3); /* join them */
 }
 lua_saveline(L, 1);
 lua_remove(L, 1); /* remove line */
 return status;
}
static void do_windows_unref (lua_State *L)
{
 struct window_unref_cell *wu;
 size_t j;
 GSL_SHELL_LOCK();
 for (j = 0; j < unref_fixed_count; j++)
 {
 object_index_remove (L, OBJECT_WINDOW, unref_fixed_list[j]);
 }
 unref_fixed_count = 0;
 for (wu = window_unref_list; wu != NULL; /* */)
 {
 struct window_unref_cell *nxt = wu->next;
 object_index_remove (L, OBJECT_WINDOW, wu->id);
 free (wu);
 wu = nxt;
 }
 window_unref_list = NULL;
 GSL_SHELL_UNLOCK();
}
static void dotty (lua_State *L) {
 const char *oldprogname = progname;
 progname = NULL;
 for (;;)
 {
 int status = loadline(L);
 if (status == -1)
	break;
 if (status == 0) 
	status = docall(L, 0, 0);
 report(L, status);
 if (status == 0 && lua_gettop(L) > 0) 
	{ /* any result to print? */
	 lua_getglobal(L, "print");
	 lua_insert(L, 1);
	 if (lua_pcall(L, lua_gettop(L)-1, 0, 0) != 0)
	 {
	 const char *fstr = "error calling " LUA_QL("print") " (%s)";
	 const char *emsg = lua_pushfstring(L, fstr, lua_tostring(L, -1));
	 l_message(progname, emsg);
	 }
	}
 do_windows_unref (L);
 }
 object_index_apply_all (L, OBJECT_WINDOW, canvas_window_close_protected);
 do {
 do_windows_unref (L);
 } while (object_index_count (L, OBJECT_WINDOW) > 0);
 
 lua_settop(L, 0); /* clear stack */
 fputs("\n", stdout);
 fflush(stdout);
 progname = oldprogname;
}
static int handle_script (lua_State *L, char **argv, int n) {
 int status;
 const char *fname;
 int narg = getargs(L, argv, n); /* collect arguments */
 lua_setglobal(L, "arg");
 fname = argv[n];
 if (strcmp(fname, "-") == 0 && strcmp(argv[n-1], "--") != 0) 
 fname = NULL; /* stdin */
 status = luaL_loadfile(L, fname);
 lua_insert(L, -(narg+1));
 if (status == 0)
 status = docall(L, narg, 0);
 else
 lua_pop(L, narg); 
 return report(L, status);
}
/* check that argument has no extra characters at the end */
#define notail(x)	{if ((x)[2] != '0円') return -1;}
static int collectargs (char **argv, int *pi, int *pv, int *pe) {
 int i;
 for (i = 1; argv[i] != NULL; i++) {
 if (argv[i][0] != '-') /* not an option? */
 return i;
 switch (argv[i][1]) { /* option */
 case '-':
 notail(argv[i]);
 return (argv[i+1] != NULL ? i+1 : 0);
 case '0円':
 return i;
 case 'i':
 notail(argv[i]);
 *pi = 1; /* go through */
 case 'v':
 notail(argv[i]);
 *pv = 1;
 break;
 case 'e':
 *pe = 1; /* go through */
 case 'l':
 if (argv[i][2] == '0円') {
 i++;
 if (argv[i] == NULL) return -1;
 }
 break;
 default: return -1; /* invalid option */
 }
 }
 return 0;
}
static int runargs (lua_State *L, char **argv, int n) {
 int i;
 for (i = 1; i < n; i++) {
 if (argv[i] == NULL) continue;
 lua_assert(argv[i][0] == '-');
 switch (argv[i][1]) { /* option */
 case 'e': {
 const char *chunk = argv[i] + 2;
 if (*chunk == '0円') chunk = argv[++i];
 lua_assert(chunk != NULL);
 if (dostring(L, chunk, "=(command line)") != 0)
 return 1;
 break;
 }
 case 'l': {
 const char *filename = argv[i] + 2;
 if (*filename == '0円') filename = argv[++i];
 lua_assert(filename != NULL);
 if (dolibrary(L, filename))
 return 1; /* stop if file fails */
 break;
 }
 default: break;
 }
 }
 return 0;
}
static int handle_luainit (lua_State *L) {
 const char *init = getenv(LUA_INIT);
 if (init == NULL) return 0; /* status OK */
 else if (init[0] == '@')
 return dofile(L, init+1);
 else
 return dostring(L, init, "=" LUA_INIT);
}
struct Smain {
 int argc;
 char **argv;
 int status;
};
static int pmain (lua_State *L) {
 struct Smain *s = (struct Smain *)lua_touserdata(L, 1);
 char **argv = s->argv;
 int script;
 int has_i = 0, has_v = 0, has_e = 0;
 globalL = L;
 if (argv[0] && argv[0][0]) progname = argv[0];
 lua_gc(L, LUA_GCSTOP, 0); /* stop collector during initialization */
 gsl_shell_openlibs (L); /* open libraries */
 lua_gc(L, LUA_GCRESTART, 0);
 dolibrary (L, "base");
 dolibrary (L, "igsl");
 dolibrary (L, "integ");
 dolibrary (L, "draw");
 s->status = handle_luainit(L);
 if (s->status != 0) return 0;
 script = collectargs(argv, &has_i, &has_v, &has_e);
 if (script < 0) { /* invalid args? */
 print_usage();
 s->status = 1;
 return 0;
 }
 if (has_v) print_version();
 s->status = runargs(L, argv, (script > 0) ? script : s->argc);
 if (s->status != 0) return 0;
 if (script)
 s->status = handle_script(L, argv, script);
 if (s->status != 0) return 0;
 if (has_i)
 dotty(L);
 else if (script == 0 && !has_e && !has_v) {
 if (lua_stdin_is_tty()) {
 print_version();
 dotty(L);
 }
 else dofile(L, NULL); /* executes stdin as a file */
 }
 return 0;
}
int main (int argc, char **argv) {
 int status;
 struct Smain s;
 pthread_mutex_init (gsl_shell_mutex, NULL);
 lua_State *L = lua_open(); /* create state */
 if (L == NULL) {
 l_message(argv[0], "cannot create state: not enough memory");
 return EXIT_FAILURE;
 }
 /* Checking 'sizeof(lua_Integer)' cannot be made in preprocessor on all compilers.
 */
#ifdef LNUM_INT32
 lua_assert( sizeof(lua_Integer) == 4 );
#elif defined(LNUM_INT64)
 lua_assert( sizeof(lua_Integer) == 8 );
#endif
 s.argc = argc;
 s.argv = argv;
 status = lua_cpcall(L, &pmain, &s);
 report(L, status);
 /* we clear the globals stack and make a full gc collect to avoid
 problem with finalizers execution order for plots and
 graphical objects. */
 mlua_table_clear (L, LUA_GLOBALSINDEX);
 lua_gc (L, LUA_GCCOLLECT, 0);
#warning UGLY HACKS
 lua_gc (L, LUA_GCCOLLECT, 0);
 lua_gc (L, LUA_GCCOLLECT, 0);
 lua_close(L);
 pthread_mutex_destroy (gsl_shell_mutex);
 return (status || s.status) ? EXIT_FAILURE : EXIT_SUCCESS;
}
void
gsl_shell_unref_plot (int id)
{
 if (unref_fixed_count < UNREF_FIXED_SIZE)
 {
 unref_fixed_list[unref_fixed_count] = id;
 unref_fixed_count ++;
 }
 else
 {
 struct window_unref_cell *cell = malloc(sizeof(struct window_unref_cell));
 cell->id = id;
 cell->next = window_unref_list;
 window_unref_list = cell;
 }
}