mirror of https://github.com/GNOME/gimp.git
337 lines
8.5 KiB
C
337 lines
8.5 KiB
C
/* TinyScheme Extensions
|
|
* (c) 2002 Visual Tools, S.A.
|
|
* Manuel Heras-Gilsanz (manuel@heras-gilsanz.com)
|
|
*
|
|
* This software is subject to the terms stated in the
|
|
* LICENSE file.
|
|
*/
|
|
|
|
#include <sys/stat.h>
|
|
#include <unistd.h>
|
|
#include <time.h>
|
|
|
|
#include <glib.h>
|
|
|
|
#include "tinyscheme/scheme-private.h"
|
|
|
|
#undef cons
|
|
|
|
typedef enum
|
|
{
|
|
FILE_TYPE_UNKNOWN = 0, FILE_TYPE_FILE, FILE_TYPE_DIR, FILE_TYPE_LINK
|
|
} FileType;
|
|
|
|
struct
|
|
named_constant {
|
|
const char *name;
|
|
FileType value;
|
|
};
|
|
|
|
struct named_constant
|
|
file_type_constants[] = {
|
|
{ "FILE-TYPE-UNKNOWN", FILE_TYPE_UNKNOWN },
|
|
{ "FILE-TYPE-FILE", FILE_TYPE_FILE },
|
|
{ "FILE-TYPE-DIR", FILE_TYPE_DIR },
|
|
{ "FILE-TYPE-LINK", FILE_TYPE_LINK },
|
|
{ NULL, 0 }
|
|
};
|
|
|
|
|
|
pointer foreign_fileexists(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
char *filename;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_string(first_arg))
|
|
return sc->F;
|
|
|
|
filename = sc->vptr->string_value(first_arg);
|
|
filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
|
|
if (g_file_test(filename, G_FILE_TEST_EXISTS))
|
|
return sc->T;
|
|
|
|
return sc->F;
|
|
}
|
|
|
|
pointer foreign_filetype(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
char *filename;
|
|
int retcode;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_string(first_arg))
|
|
return sc->F;
|
|
|
|
filename = sc->vptr->string_value(first_arg);
|
|
filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
|
|
|
|
if (g_file_test(filename, G_FILE_TEST_IS_REGULAR))
|
|
retcode = FILE_TYPE_FILE;
|
|
else if (g_file_test(filename, G_FILE_TEST_IS_DIR))
|
|
retcode = FILE_TYPE_DIR;
|
|
else if (g_file_test(filename, G_FILE_TEST_IS_SYMLINK))
|
|
retcode = FILE_TYPE_LINK;
|
|
else
|
|
retcode = FILE_TYPE_UNKNOWN;
|
|
|
|
return sc->vptr->mk_integer(sc, retcode);
|
|
}
|
|
|
|
pointer foreign_filesize(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
pointer ret;
|
|
struct stat buf;
|
|
char * filename;
|
|
int retcode;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_string(first_arg))
|
|
return sc->F;
|
|
|
|
filename = sc->vptr->string_value(first_arg);
|
|
filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
|
|
retcode = stat(filename, &buf);
|
|
if (retcode == 0)
|
|
ret = sc->vptr->mk_integer(sc,buf.st_size);
|
|
else
|
|
ret = sc->F;
|
|
return ret;
|
|
}
|
|
|
|
pointer foreign_filedelete(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
pointer ret;
|
|
char * filename;
|
|
int retcode;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_string(first_arg)) {
|
|
return sc->F;
|
|
}
|
|
|
|
filename = sc->vptr->string_value(first_arg);
|
|
filename = g_filename_from_utf8 (filename, -1, NULL, NULL, NULL);
|
|
retcode = unlink(filename);
|
|
if (retcode == 0)
|
|
ret = sc->T;
|
|
else
|
|
ret = sc->F;
|
|
return ret;
|
|
}
|
|
|
|
pointer foreign_diropenstream(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
char *dirpath;
|
|
GDir *dir;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_string(first_arg))
|
|
return sc->F;
|
|
|
|
dirpath = sc->vptr->string_value(first_arg);
|
|
dirpath = g_filename_from_utf8 (dirpath, -1, NULL, NULL, NULL);
|
|
|
|
dir = g_dir_open(dirpath, 0, NULL);
|
|
if (dir == NULL)
|
|
return sc->F;
|
|
|
|
/* Stuffing a pointer in a long may not always be portable ~~~~~ */
|
|
return (sc->vptr->mk_integer(sc, (long) dir));
|
|
}
|
|
|
|
pointer foreign_dirreadentry(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
GDir *dir;
|
|
gchar *entry;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_integer(first_arg))
|
|
return sc->F;
|
|
|
|
dir = (GDir *) sc->vptr->ivalue(first_arg);
|
|
if (dir == NULL)
|
|
return sc->F;
|
|
|
|
entry = (gchar *)g_dir_read_name(dir);
|
|
if (entry == NULL)
|
|
return sc->EOF_OBJ;
|
|
|
|
entry = g_filename_to_utf8 (entry, -1, NULL, NULL, NULL);
|
|
return (sc->vptr->mk_string(sc, entry));
|
|
}
|
|
|
|
pointer foreign_dirrewind(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
GDir *dir;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_integer(first_arg))
|
|
return sc->F;
|
|
|
|
dir = (GDir *) sc->vptr->ivalue(first_arg);
|
|
if (dir == NULL)
|
|
return sc->F;
|
|
|
|
g_dir_rewind(dir);
|
|
return sc->T;
|
|
}
|
|
|
|
pointer foreign_dirclosestream(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
GDir *dir;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_integer(first_arg))
|
|
return sc->F;
|
|
|
|
dir = (GDir *) sc->vptr->ivalue(first_arg);
|
|
if (dir == NULL)
|
|
return sc->F;
|
|
|
|
g_dir_close(dir);
|
|
return sc->T;
|
|
}
|
|
|
|
|
|
pointer foreign_time(scheme *sc, pointer args)
|
|
{
|
|
time_t now;
|
|
struct tm *now_tm;
|
|
pointer ret;
|
|
|
|
if (args != sc->NIL)
|
|
return sc->F;
|
|
|
|
#if 1
|
|
time(&now);
|
|
now_tm = localtime(&now);
|
|
#else
|
|
GTime time;
|
|
GDate date;
|
|
|
|
g_date_set_time(&date, &now);
|
|
g_date_to_struct_tm(&now, &now_tm);
|
|
#endif
|
|
|
|
ret = sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_year),
|
|
sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_mon),
|
|
sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_mday),
|
|
sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_hour),
|
|
sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_min),
|
|
sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) now_tm->tm_sec),sc->NIL))))));
|
|
|
|
return ret;
|
|
}
|
|
|
|
pointer foreign_gettimeofday(scheme *sc, pointer args)
|
|
{
|
|
GTimeVal tv;
|
|
pointer ret;
|
|
|
|
g_get_current_time(&tv);
|
|
|
|
ret = sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) tv.tv_sec),
|
|
sc->vptr->cons(sc, sc->vptr->mk_integer(sc,(long) tv.tv_usec),
|
|
sc->NIL));
|
|
|
|
return ret;
|
|
}
|
|
|
|
pointer foreign_usleep(scheme *sc, pointer args)
|
|
{
|
|
pointer first_arg;
|
|
long usec;
|
|
|
|
if (args == sc->NIL)
|
|
return sc->F;
|
|
|
|
first_arg = sc->vptr->pair_car(args);
|
|
if (!sc->vptr->is_integer(first_arg))
|
|
return sc->F;
|
|
|
|
usec = sc->vptr->ivalue(first_arg);
|
|
g_usleep(usec);
|
|
|
|
return sc->T;
|
|
}
|
|
|
|
/* This function gets called when TinyScheme is loading the extension */
|
|
void init_ftx (scheme *sc)
|
|
{
|
|
int i;
|
|
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"time"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_time));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"gettimeofday"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_gettimeofday));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"usleep"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_usleep));
|
|
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"file-exists?"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_fileexists));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"file-type"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_filetype));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"file-size"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_filesize));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"file-delete"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_filedelete));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"dir-open-stream"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_diropenstream));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"dir-read-entry"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_dirreadentry));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"dir-rewind"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_dirrewind));
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc,"dir-close-stream"),
|
|
sc->vptr->mk_foreign_func(sc, foreign_dirclosestream));
|
|
|
|
for (i = 0; file_type_constants[i].name != NULL; ++i)
|
|
{
|
|
sc->vptr->scheme_define(sc, sc->global_env,
|
|
sc->vptr->mk_symbol(sc, file_type_constants[i].name),
|
|
sc->vptr->mk_integer(sc, file_type_constants[i].value));
|
|
}
|
|
}
|