File: hslwarn.c

package info (click to toggle)
haskell-lua 2.3.3%2Bds1-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 276 kB
  • sloc: haskell: 1,582; ansic: 403; makefile: 7
file content (157 lines) | stat: -rw-r--r-- 4,617 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
/*
** Large parts of the below code are adapted from the default warning
** functions defined in lauxlib.c.
**
** See Copyright Notice in lua.h
*/

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include "lua.h"
#include "lauxlib.h"

#define HSLUA_RFLD_WARNF "HsLua warn hook"
#define HSLUA_RFLD_WARNINGS "HsLua warnings"

/* print an error message */
#if !defined(lua_writestringerror)
#define lua_writestringerror(s,p)               \
  (fprintf(stderr, (s), (p)), fflush(stderr))
#endif

/*
** Initializes the warnings table.
*/
static void reset_warnings (lua_State *L) {
  lua_createtable(L, 1, 0);
  lua_setfield(L, LUA_REGISTRYINDEX, HSLUA_RFLD_WARNINGS);
}

/*
** Stores the warning in the registry.
*/
static void store_warning (lua_State *L, const char *message) {
  if (lua_getfield(L, LUA_REGISTRYINDEX, HSLUA_RFLD_WARNINGS) != LUA_TTABLE) {
    return;
  }
  lua_pushstring(L, message);
  lua_seti(L, -2, luaL_len(L, -2) + 1);  /* append message */
  lua_pop(L, 1);  /* messages table */
}

/* Concatenates all collected warnings and pushes the result to the stack. */
static void pushwarning (lua_State *L) {
  if (lua_getfield(L, LUA_REGISTRYINDEX, HSLUA_RFLD_WARNINGS) != LUA_TTABLE) {
    lua_pushliteral(L, "");
    return;
  }

  int tblidx = lua_absindex(L, -1);
  lua_Integer last = luaL_len(L, tblidx);
  luaL_Buffer b;
  luaL_buffinit(L, &b);
  for (int i = 1; i <= last; i++) {
    if (lua_geti(L, tblidx, i) != LUA_TSTRING) {
      /* not a string; skip it silently */
      lua_pop(L, 1);
    } else {
      luaL_addvalue(&b);
    }
  }
  lua_remove(L, -2);  /* warnings table */
  luaL_pushresult(&b);
}

static void call_warn_hook (lua_State *L) {
  if (lua_getfield(L, LUA_REGISTRYINDEX, HSLUA_RFLD_WARNF) == LUA_TFUNCTION) {
    pushwarning(L);
    lua_call(L, 1, 0);
  }
}

/*
** Warning functions:
** warnfoff: warning system is off
** warnfon: ready to start a new message
** warnfcont: previous message is to be continued
*/
static void warnfoff (void *ud, const char *message, int tocont);
static void warnfon (void *ud, const char *message, int tocont);
static void warnfcont (void *ud, const char *message, int tocont);

/*
** Check whether message is a control message. If so, execute the
** control or ignore it if unknown.
*/
static int checkcontrol (lua_State *L, const char *message, int tocont) {
  if (tocont || *(message++) != '@')  /* not a control message? */
    return 0;
  else {
    if (strcmp(message, "off") == 0)
      lua_setwarnf(L, warnfoff, L);  /* turn warnings off */
    else if (strcmp(message, "on") == 0)
      lua_setwarnf(L, warnfon, L);   /* turn warnings on */
    return 1;  /* it was a control message */
  }
}

/*
** Does not write the warning to stderr, but still records the message
** so it can be processed by the custom hook.
*/
static void warnfoff (void *ud, const char *message, int tocont) {
  lua_State *L = (lua_State *)ud;
  if (checkcontrol(L, message, tocont)) {
    return; /* nothing else to be done */
  }
  store_warning(L, message);
  if (!tocont) {  /* last part */
    call_warn_hook(L);  /* call the warnings hook */
    reset_warnings(L);  /* reset warnings table */
  }
}


/*
** Writes the message and handle 'tocont', finishing the message
** if needed and setting the next warn function.
*/
static void warnfcont (void *ud, const char *message, int tocont) {
  lua_State *L = (lua_State *)ud;
  lua_writestringerror("%s", message);  /* write message */
  store_warning(L, message);
  if (tocont)  /* not the last part? */
    lua_setwarnf(L, warnfcont, L);  /* to be continued */
  else {  /* last part */
    lua_writestringerror("%s", "\n");  /* finish message with end-of-line */
    lua_setwarnf(L, warnfon, L);  /* next call is a new message */
    call_warn_hook(L);  /* call the warnings hook */
    reset_warnings(L);  /* reset warnings table */
  }
}

/*
** Records a warning, and writes a warning prefix followed by the
** warning to stderr.
*/
static void warnfon (void *ud, const char *message, int tocont) {
  lua_State *L = (lua_State *)ud;
  if (checkcontrol(L, message, tocont))  /* control message? */
    return;  /* nothing else to be done */
  lua_writestringerror("%s", "Lua warning: ");  /* start a new warning */
  warnfcont(ud, message, tocont);  /* finish processing */
}


/*
** Sets the object at the top of the stack as the function that is
** called on the concatenated warning messages. Pops the function from
** the stack.
*/
void hsluaL_setwarnf (lua_State *L) {
  lua_setfield(L, LUA_REGISTRYINDEX, HSLUA_RFLD_WARNF);
  reset_warnings(L);
  lua_setwarnf(L, warnfoff, L);
}