/*=gfunc in_p
*
* what: test for string in list
* general_use:
* exparg: test-string, string to look for
* exparg: string-list, list of strings to check,, list
*
* doc: Return SCM_BOOL_T if the first argument string is found
* in one of the entries in the second (list-of-strings) argument.
=*/
SCM
ag_scm_in_p(SCM obj, SCM list)
{
int len;
size_t lenz;
SCM car;
char const * pz1;
if (! AG_SCM_STRING_P(obj))
return SCM_UNDEFINED;
pz1 = scm_i_string_chars(obj);
lenz = AG_SCM_STRLEN(obj);
/*
* If the second argument is a string somehow, then treat
* this as a straight out string comparison
*/
if (AG_SCM_STRING_P(list)) {
if ( (AG_SCM_STRLEN(list) == lenz)
&& (strncmp(pz1, scm_i_string_chars(list), lenz) == 0))
return SCM_BOOL_T;
return SCM_BOOL_F;
}
len = (int)scm_ilength(list);
if (len == 0)
return SCM_BOOL_F;
/*
* Search all the lists and sub-lists passed in
*/
while (len-- > 0) {
car = SCM_CAR(list);
list = SCM_CDR(list);
/*
* This routine is listed as getting a list as the second
* argument. That means that if someone builds a list and
* hands it to us, it magically becomes a nested list.
* This unravels that.
*/
if (! AG_SCM_STRING_P(car)) {
if (ag_scm_in_p(obj, car) == SCM_BOOL_T)
return SCM_BOOL_T;
continue;
}
if ( (AG_SCM_STRLEN(car) == lenz)
&& (strncmp(pz1, scm_i_string_chars(car), lenz) == 0) )
return SCM_BOOL_T;
}
return SCM_BOOL_F;
}
/*=gfunc string_tr
*
* what: convert characters with new result
* general_use:
*
* exparg: source, string to transform
* exparg: match, characters to be converted
* exparg: translation, conversion list
*
* doc: This is identical to @code{string-tr!}, except that it does not
* over-write the previous value.
=*/
SCM
ag_scm_string_tr(SCM Str, SCM From, SCM To)
{
size_t lenz = AG_SCM_STRLEN(Str);
SCM res = AG_SCM_STR2SCM(scm_i_string_chars(Str), lenz);
return ag_scm_string_tr_x(res, From, To);
}
/*=gfunc extract
*
* what: extract text from another file
* general_use:
* exparg: file-name, name of file with text
* exparg: marker-fmt, format for marker text
* exparg: caveat, warn about changing marker, opt
* exparg: default, default initial text, opt
*
* doc:
*
* This function is used to help construct output files that may contain
* text that is carried from one version of the output to the next.
*
* The first two arguments are required, the second are optional:
*
* @itemize @bullet
* @item
* The @code{file-name} argument is used to name the file that
* contains the demarcated text.
* @item
* The @code{marker-fmt} is a formatting string that is used to construct
* the starting and ending demarcation strings. The sprintf function is
* given the @code{marker-fmt} with two arguments. The first is either
* "START" or "END". The second is either "DO NOT CHANGE THIS COMMENT"
* or the optional @code{caveat} argument.
* @item
* @code{caveat} is presumed to be absent if it is the empty string
* (@code{""}). If absent, ``DO NOT CHANGE THIS COMMENT'' is used
* as the second string argument to the @code{marker-fmt}.
* @item
* When a @code{default} argument is supplied and no pre-existing text
* is found, then this text will be inserted between the START and END
* markers.
* @end itemize
*
* @noindent
* The resulting strings are presumed to be unique within
* the subject file. As a simplified example:
*
* @example
* [+ (extract "fname" "// %s - SOMETHING - %s" ""
* "example default") +]
* @end example
* @noindent
* will result in the following text being inserted into the output:
*
* @example
* // START - SOMETHING - DO NOT CHANGE THIS COMMENT
* example default
* // END - SOMETHING - DO NOT CHANGE THIS COMMENT
* @end example
*
* @noindent
* The ``@code{example default}'' string can then be carried forward to
* the next generation of the output, @strong{@i{provided}} the output
* is not named "@code{fname}" @i{and} the old output is renamed to
* "@code{fname}" before AutoGen-eration begins.
*
* @table @strong
* @item NB:
* You can set aside previously generated source files inside the pseudo
* macro with a Guile/scheme function, extract the text you want to keep
* with this extract function. Just remember you should delete it at the
* end, too. Here is an example from my Finite State Machine generator:
*
* @example
* [+ AutoGen5 Template -*- Mode: text -*-
* h=%s-fsm.h c=%s-fsm.c
* (shellf
* "test -f %1$s-fsm.h && mv -f %1$s-fsm.h .fsm.head
* test -f %1$s-fsm.c && mv -f %1$s-fsm.c .fsm.code" (base-name))
* +]
* @end example
*
* This code will move the two previously produced output files to files
* named ".fsm.head" and ".fsm.code". At the end of the 'c' output
* processing, I delete them.
*
* @item also NB:
* This function presumes that the output file ought to be editable so
* that the code between the @code{START} and @code{END} marks can be edited
* by the template user. Consequently, when the @code{(extract ...)} function
* is invoked, if the @code{writable} option has not been specified, then
* it will be set at that point. If this is not the desired behavior, the
* @code{--not-writable} command line option will override this.
* Also, you may use the guile function @code{(chmod "file" mode-value)}
* to override whatever AutoGen is using for the result mode.
* @end table
=*/
SCM
ag_scm_extract(SCM file, SCM marker, SCM caveat, SCM def)
{
char const * pzStart;
char const * pzEnd;
char const * pzText;
if (! AG_SCM_STRING_P(file) || ! AG_SCM_STRING_P(marker))
return SCM_UNDEFINED;
pzText = load_extract_file(ag_scm2zchars(file, "extr file"));
{
char const * pzMarker = ag_scm2zchars(marker, "marker");
char const * pzCaveat = EXTRACT_CAVEAT;
if (AG_SCM_STRING_P(caveat) && (AG_SCM_STRLEN(caveat) > 0))
pzCaveat = ag_scm2zchars(caveat, "caveat");
pzStart = aprf(pzMarker, EXTRACT_START, pzCaveat);
pzEnd = aprf(pzMarker, EXTRACT_END, pzCaveat);
}
{
SCM res;
if (pzText == NULL)
res = mk_empty_text(pzStart, pzEnd, def);
else res = get_text(pzText, pzStart, pzEnd, def);
AGFREE((void*)pzStart);
AGFREE((void*)pzEnd);
return res;
}
}
/**
* Replace marker text.
*
* Replace all occurrances of the marker text with the substitution text.
* The result is stored in an automatically freed temporary buffer.
*
* @param src_str The source string
* @param str_len The length of the string
* @param match the SCM-ized marker string
* @param repl the SCM-ized replacement string
* @param ppz_res pointer to the result pointer
* @param res_len pointer to result length
*/
static void
do_substitution(
char const * src_str,
ssize_t str_len,
SCM match,
SCM repl,
char ** ppz_res,
ssize_t * res_len)
{
char * pzMatch = ag_scm2zchars(match, "match text");
char * rep_str = ag_scm2zchars(repl, "repl text");
int mark_len = (int)AG_SCM_STRLEN(match);
int repl_len = (int)AG_SCM_STRLEN(repl);
{
int ct = sub_count(src_str, pzMatch);
if (ct == 0)
return; /* No substitutions -- no work. */
str_len += (repl_len - mark_len) * ct;
}
{
char * dest = scribble_get(str_len + 1);
*ppz_res = dest;
*res_len = str_len;
for (;;) {
char const * next = strstr(src_str, pzMatch);
size_t len;
if (next == NULL)
break;
len = (size_t)(next - src_str);
if (len != 0) {
memcpy(dest, src_str, len);
dest += len;
}
memcpy(dest, rep_str, (size_t)repl_len);
dest += repl_len;
src_str = next + mark_len;
}
strcpy(dest, src_str);
}
}
/*=gfunc string_tr_x
*
* what: convert characters
* general_use:
*
* exparg: source, string to transform
* exparg: match, characters to be converted
* exparg: translation, conversion list
*
* doc: This is the same as the @code{tr(1)} program, except the
* string to transform is the first argument. The second and
* third arguments are used to construct mapping arrays for the
* transformation of the first argument.
*
* It is too bad this little program has so many different
* and incompatible implementations!
=*/
SCM
ag_scm_string_tr_x(SCM str, SCM from_xform, SCM to_xform)
{
unsigned char ch_map[ 1 << 8 /* bits-per-byte */ ];
int i = sizeof(ch_map) - 1;
char * from = ag_scm2zchars(from_xform, "str");
char * to = ag_scm2zchars(to_xform, "str");
do {
ch_map[i] = (unsigned char)i;
} while (--i > 0);
for (; i <= (int)sizeof(ch_map) - 1; i++) {
unsigned char fch = (unsigned char)*(from++);
unsigned char tch = (unsigned char)*(to++);
if (tch == NUL) {
to--;
tch = (unsigned char)to[-1];
}
switch (fch) {
case NUL:
goto map_done;
case '-':
if ((i > 0) && (tch == '-')) {
unsigned char fs = (unsigned char)from[-2];
unsigned char fe = (unsigned char)from[0];
unsigned char ts = (unsigned char)to[-2];
unsigned char te = (unsigned char)to[0];
if (te != NUL) {
while (fs < fe) {
ch_map[ fs++ ] = ts;
if (ts < te) ts++;
}
break;
}
}
default:
ch_map[ fch ] = tch;
}
} map_done:;
to = C(char *, scm_i_string_chars(str));
i = (int)AG_SCM_STRLEN(str);
while (i-- > 0) {
*to = (char)ch_map[ (int)*to ];
to++;
}
return str;
}
/*=gfunc string_tr_x
*
* what: convert characters
* general_use:
*
* exparg: source, string to transform
* exparg: match, characters to be converted
* exparg: translation, conversion list
*
* doc: This is the same as the @code{tr(1)} program, except the
* string to transform is the first argument. The second and
* third arguments are used to construct mapping arrays for the
* transformation of the first argument.
*
* It is too bad this little program has so many different
* and incompatible implementations!
=*/
SCM
ag_scm_string_tr_x(SCM str, SCM from_xform, SCM to_xform)
{
unsigned char ch_map[ 1 << 8 /* bits-per-byte */ ];
int i = sizeof(ch_map) - 1;
char* pzFrom = ag_scm2zchars(from_xform, "str");
char* pzTo = ag_scm2zchars(to_xform, "str");
do {
ch_map[i] = i;
} while (--i > 0);
for (;i <= sizeof(ch_map) - 1;i++) {
unsigned char fch = (unsigned char)*(pzFrom++);
unsigned char tch = (unsigned char)*(pzTo++);
if (tch == NUL) {
pzTo--;
tch = pzTo[-1];
}
switch (fch) {
case NUL:
goto mapDone;
case '-':
if ((i > 0) && (tch == '-')) {
unsigned char fs = (unsigned char)pzFrom[-2];
unsigned char fe = (unsigned char)pzFrom[0];
unsigned char ts = (unsigned char)pzTo[-2];
unsigned char te = (unsigned char)pzTo[0];
if (te != NUL) {
while (fs < fe) {
ch_map[ fs++ ] = ts;
if (ts < te) ts++;
}
break;
}
}
default:
ch_map[ fch ] = tch;
}
} mapDone:;
pzTo = (char*)(void*)AG_SCM_CHARS(str);
i = AG_SCM_STRLEN(str);
while (i-- > 0) {
*pzTo = ch_map[ (int)*pzTo ];
pzTo++;
}
return str;
}
/*=gfunc chdir
*
* what: Change current directory
*
* exparg: dir, new directory name
*
* doc: Sets the current directory for AutoGen. Shell commands will run
* from this directory as well. This is a wrapper around the Guile
* native function. It returns its directory name argument and
* fails the program on failure.
=*/
SCM
ag_scm_chdir(SCM dir)
{
static char const zChdirDir[] = "chdir directory";
scm_chdir(dir);
/*
* We're still here, so we have a valid argument.
*/
if (pCurDir != NULL)
free(pCurDir);
{
char const * pz = ag_scm2zchars(dir, zChdirDir);
pCurDir = malloc(AG_SCM_STRLEN(dir) + 1);
strcpy((char*)pCurDir, pz);
}
return dir;
}
/**
* Could not find the file or could not find the markers.
* Either way, emit an empty enclosure.
*/
static SCM
mk_empty_text(char const* pzStart, char const* pzEnd, SCM def)
{
size_t mlen = strlen(pzStart) + strlen(pzEnd) + 3;
char* pzOut;
if (! AG_SCM_STRING_P(def)) {
pzOut = ag_scribble(mlen);
sprintf(pzOut, LINE_CONCAT3_FMT+3, pzStart, pzEnd);
} else {
char const * pzDef = ag_scm2zchars(def, "dft extr str");
mlen += AG_SCM_STRLEN(def) + 1;
pzOut = ag_scribble(mlen);
sprintf(pzOut, LINE_CONCAT3_FMT, pzStart, pzDef, pzEnd);
}
return AG_SCM_STR02SCM(pzOut);
}
/*=gfunc string_substitute
*
* what: multiple global replacements
* general_use:
*
* exparg: source, string to transform
* exparg: match, substring or substring list to be replaced
* exparg: repl, replacement strings or substrings
*
* doc: @code{match} and @code{repl} may be either a single string or
* a list of strings. Either way, they must have the same structure
* and number of elements. For example, to replace all amphersands,
* less than and greater than characters, do something like this:
*
* @example
* (string-substitute source
* (list "&" "<" ">")
* (list "&" "<" ">"))
* @end example
=*/
SCM
ag_scm_string_substitute(SCM str, SCM Match, SCM Repl)
{
char const * text;
ssize_t len;
SCM res;
if (! AG_SCM_STRING_P(str))
return SCM_UNDEFINED;
text = scm_i_string_chars(str);
len = (ssize_t)AG_SCM_STRLEN(str);
if (AG_SCM_STRING_P(Match))
do_substitution(text, len, Match, Repl, (char **)&text, &len);
else
do_multi_subs((char **)&text, &len, Match, Repl);
res = AG_SCM_STR2SCM(text, (size_t)len);
return res;
}
/*=gfunc string_substitute
*
* what: multiple global replacements
* general_use:
*
* exparg: source, string to transform
* exparg: match, substring or substring list to be replaced
* exparg: repl, replacement strings or substrings
*
* doc: @code{match} and @code{repl} may be either a single string or
* a list of strings. Either way, they must have the same structure
* and number of elements. For example, to replace all amphersands,
* less than and greater than characters, do something like this:
*
* @example
* (string-substitute source
* (list "&" "<" ">")
* (list "&" "<" ">"))
* @end example
=*/
SCM
ag_scm_string_substitute(SCM Str, SCM Match, SCM Repl)
{
char const * pzStr;
ssize_t len;
SCM res;
if (! AG_SCM_STRING_P(Str))
return SCM_UNDEFINED;
pzStr = AG_SCM_CHARS(Str);
len = AG_SCM_STRLEN(Str);
if (AG_SCM_STRING_P(Match))
do_substitution(pzStr, len, Match, Repl, (char**)&pzStr, &len);
else
do_multi_subs((char**)&pzStr, &len, Match, Repl);
res = AG_SCM_STR2SCM(pzStr, len);
return res;
}
/**
* The template output goes to stdout. Perhaps because output
* is for a CGI script. In any case, this case must be handled
* specially.
*/
static void
do_stdout_tpl(tTemplate * pTF)
{
char const * pzRes;
SCM res;
pzLastScheme = NULL; /* We cannot be in Scheme processing */
switch (setjmp (fileAbort)) {
case SUCCESS:
break;
case PROBLEM:
if (*pzOopsPrefix != NUL) {
fprintf(stdout, DO_STDOUT_TPL_ABANDONED, pzOopsPrefix);
pzOopsPrefix = zNil;
}
fclose(stdout);
return;
default:
fprintf(stdout, DO_STDOUT_TPL_BADR, pzOopsPrefix);
case FAILURE:
exit(EXIT_FAILURE);
}
pzCurSfx = DO_STDOUT_TPL_NOSFX;
currDefCtx = rootDefCtx;
pCurFp = &fpRoot;
fpRoot.pFile = stdout;
fpRoot.pzOutName = DO_STDOUT_TPL_STDOUT;
fpRoot.flags = FPF_NOUNLINK | FPF_STATIC_NM;
if (OPT_VALUE_TRACE >= TRACE_EVERYTHING)
fputs(DO_STDOUT_TPL_START_STD, pfTrace);
/*
* IF there is a CGI prefix for error messages,
* THEN divert all output to a temporary file so that
* the output will be clean for any error messages we have to emit.
*/
if (*pzOopsPrefix == NUL)
generateBlock(pTF, pTF->aMacros, pTF->aMacros + pTF->macroCt);
else {
(void)ag_scm_out_push_new(SCM_UNDEFINED);
generateBlock(pTF, pTF->aMacros, pTF->aMacros + pTF->macroCt);
/*
* Read back in the spooled output. Make sure it starts with
* a content-type: prefix. If not, we supply our own HTML prefix.
*/
res = ag_scm_out_pop(SCM_BOOL_T);
pzRes = AG_SCM_CHARS(res);
/* 13: "content-type:" */
if (strneqvcmp(pzRes, DO_STDOUT_TPL_CONTENT, 13) != 0)
fputs(DO_STDOUT_TPL_CONTENT, stdout);
fwrite(pzRes, AG_SCM_STRLEN(res), (size_t)1, stdout);
}
fclose(stdout);
}
/*
* process a single scheme expression, yielding text that gets processed
* into AutoGen definitions.
*/
static void
alist_to_autogen_def(void)
{
static char const zSchemeText[] = "Scheme Computed Definitions";
static char const zWrap[] = "(alist->autogen-def %s)";
char* pzText = ++(pCurCtx->pzScan);
char* pzEnd = (char*)skipScheme(pzText, pzText + strlen(pzText));
SCM res;
size_t res_len;
tScanCtx* pCtx;
/*
* Wrap the scheme expression with the `alist->autogen-def' function
*/
{
char endCh = *pzEnd;
*pzEnd = NUL;
pzText = aprf(zWrap, pzText);
*pzEnd = endCh;
}
/*
* Run the scheme expression. The result is autogen definition text.
*/
procState = PROC_STATE_GUILE_PRELOAD;
res = ag_scm_c_eval_string_from_file_line(
pzText, pCurCtx->pzCtxFname, pCurCtx->lineNo );
/*
* The result *must* be a string, or we choke.
*/
if (! AG_SCM_STRING_P(res)) {
static char const zEr[] =
"Scheme definition expression does not yield string:\n";
AG_ABEND(zEr);
}
res_len = AG_SCM_STRLEN(res);
procState = PROC_STATE_LOAD_DEFS;
pCurCtx->pzScan = pzEnd;
AGFREE(pzText);
/*
* Now, push the resulting string onto the input stack
* and link the new scan data into the context stack
*/
pCtx = (tScanCtx*)AGALOC(sizeof(tScanCtx) + 4 + res_len, "lex scan ctx");
pCtx->pCtx = pCurCtx;
pCurCtx = pCtx;
/*
* Set up the rest of the context structure
*/
AGDUPSTR(pCtx->pzCtxFname, zSchemeText, "scheme text");
pCtx->pzScan = \
pCtx->pzData = (char*)(pCtx+1);
pCtx->lineNo = 0;
memcpy((void*)(pCtx->pzScan), (void*)AG_SCM_CHARS(res), res_len);
pCtx->pzScan[ res_len ] = NUL;
/*
* At this point, the next token will be obtained
* from the newly allocated context structure.
* When empty, input will resume from the '}' that we
* left as the next input token in the old context.
*/
}
/*=gfunc raw_shell_str
*
* what: single quote shell string
* general_use:
*
* exparg: string, string to transform
*
* doc:
* Convert the text of the string into a singly quoted string
* that a normal shell will process into the original string.
* (It will not do macro expansion later, either.)
* Contained single quotes become tripled, with the middle quote
* escaped with a backslash. Normal shells will reconstitute the
* original string.
*
* @strong{Notice}: some shells will not correctly handle unusual
* non-printing characters. This routine works for most reasonably
* conventional ASCII strings.
=*/
SCM
ag_scm_raw_shell_str(SCM obj)
{
char * data;
char * pz;
char * pzFree;
data = ag_scm2zchars(obj, "AG Object");
{
size_t dtaSize = AG_SCM_STRLEN(obj) + 3; /* NUL + 2 quotes */
pz = data-1;
for (;;) {
pz = strchr(pz+1, '\'');
if (pz == NULL)
break;
dtaSize += 3; /* '\'' -> 3 additional chars */
}
pzFree = pz = AGALOC(dtaSize + 2, "raw string");
}
/*
* Handle leading single quotes before starting the first quote.
*/
while (*data == '\'') {
*(pz++) = '\\';
*(pz++) = '\'';
/*
* IF pure single quotes, then we're done.
*/
if (*++data == NUL) {
*pz = NUL;
goto returnString;
}
}
/*
* Start quoting. If the string is empty, we wind up with two quotes.
*/
*(pz++) = '\'';
for (;;) {
switch (*(pz++) = *(data++)) {
case NUL:
goto loopDone;
case '\'':
/*
* We've inserted a single quote, which ends the quoting session.
* Now, insert escaped quotes for every quote char we find, then
* restart the quoting.
*/
data--;
do {
*(pz++) = '\\';
*(pz++) = '\'';
} while (*++data == '\'');
if (*data == NUL) {
*pz = NUL;
goto returnString;
}
*(pz++) = '\'';
}
} loopDone:;
pz[-1] = '\'';
*pz = NUL;
returnString:
{
SCM res = AG_SCM_STR02SCM(pzFree);
AGFREE(pzFree);
return res;
}
}
/*=gfunc join
*
* what: join string list with separator
* general_use:
* exparg: separator, string to insert between entries
* exparg: list, list of strings to join,, list
*
* doc: With the first argument as the separator string,
* joins together an a-list of strings into one long string.
* The list may contain nested lists, partly because you
* cannot always control that.
=*/
SCM
ag_scm_join(SCM sep, SCM list)
{
int l_len, sv_l_len;
SCM car;
SCM alist = list;
size_t sep_len;
size_t str_len;
char * pzRes;
char const * pzSep;
char * pzScan;
if (! AG_SCM_STRING_P(sep))
return SCM_UNDEFINED;
sv_l_len = l_len = (int)scm_ilength(list);
if (l_len == 0)
return AG_SCM_STR02SCM(zNil);
pzSep = scm_i_string_chars(sep);
sep_len = AG_SCM_STRLEN(sep);
str_len = 0;
/*
* Count up the lengths of all the strings to be joined.
*/
for (;;) {
car = SCM_CAR(list);
list = SCM_CDR(list);
/*
* This routine is listed as getting a list as the second
* argument. That means that if someone builds a list and
* hands it to us, it magically becomes a nested list.
* This unravels that.
*/
if (! AG_SCM_STRING_P(car)) {
if (car != SCM_UNDEFINED)
car = ag_scm_join(sep, car);
if (! AG_SCM_STRING_P(car))
return SCM_UNDEFINED;
}
str_len += AG_SCM_STRLEN(car);
if (--l_len <= 0)
break;
str_len += sep_len;
}
l_len = sv_l_len;
pzRes = pzScan = scribble_get((ssize_t)str_len);
/*
* Now, copy each one into the output
*/
for (;;) {
size_t cpy_len;
car = SCM_CAR(alist);
alist = SCM_CDR(alist);
/*
* This unravels nested lists.
*/
if (! AG_SCM_STRING_P(car))
car = ag_scm_join(sep, car);
cpy_len = AG_SCM_STRLEN(car);
memcpy(VOIDP(pzScan), scm_i_string_chars(car), cpy_len);
pzScan += cpy_len;
/*
* IF we reach zero, then do not insert a separation and bail out
*/
if (--l_len <= 0)
break;
memcpy(VOIDP(pzScan), VOIDP(pzSep), sep_len);
pzScan += sep_len;
}
return AG_SCM_STR2SCM(pzRes, str_len);
}
