/*
**
** read an error file to internal buffer and substitute the filename
**
*/
char *ePerl_ReadErrorFile(char *filename, char *scriptfile, char *scripturl)
{
char *rc;
FILE *fp = NULL;
char *cpBuf = NULL;
int nBuf;
char *cp;
if ((fp = fopen(filename, "r")) == NULL) {
ePerl_SetError("Cannot open error file %s for reading", filename);
CU(NULL);
}
fseek(fp, 0, SEEK_END);
nBuf = ftell(fp);
if ((cpBuf = (char *)malloc(sizeof(char) * nBuf * 2)) == NULL) {
ePerl_SetError("Cannot allocate %d bytes of memory", nBuf * 2);
CU(NULL);
}
fseek(fp, 0, SEEK_SET);
if (fread(cpBuf, nBuf, 1, fp) == 0) {
ePerl_SetError("Cannot read from file %s", filename);
CU(NULL);
}
cpBuf[nBuf] = '\0';
for (cp = cpBuf; cp < cpBuf+nBuf; ) {
if ((cp = strstr(cp, scriptfile)) != NULL) {
#ifdef HAVE_MEMMOVE
(void)memmove(cp+strlen(scripturl), cp+strlen(scriptfile), strlen(cp+strlen(scriptfile))+1);
#else
(void)bcopy(cp+strlen(scriptfile), cp+strlen(scripturl), strlen(cp+strlen(scriptfile))+1);
#endif
(void)memcpy(cp, scripturl, strlen(scripturl));
cp += strlen(scripturl);
continue;
}
break;
}
RETURN_WVAL(cpBuf);
CUS:
if (cpBuf)
free(cpBuf);
if (fp)
fclose(fp);
RETURN_EXRC;
}
/*
** convert buffer from bristled format to plain format
*/
char *ePerl_Bristled2Plain(char *cpBuf)
{
char *rc;
char *cpOutBuf = NULL;
char *cpOut = NULL;
char *cps, *cpe;
char *cps2, *cpe2;
int nBuf;
char *cpEND;
int n;
if (strlen(cpBuf) == 0) {
/* make sure we return a buffer which the caller can free() */
cpOutBuf = (char *)malloc(sizeof(char) * 1);
*cpOutBuf = NUL;
return cpOutBuf;
}
nBuf = strlen(cpBuf);
cpEND = cpBuf+nBuf;
/* allocate memory for the Perl code */
n = sizeof(char) * nBuf * 10;
if (nBuf < 1024)
n = 16384;
if ((cpOutBuf = (char *)malloc(n)) == NULL) {
ePerl_SetError("Cannot allocate %d bytes of memory", n);
CU(NULL);
}
cpOut = cpOutBuf;
/* now step through the file and convert it to legal Perl code.
This is a bit complicated because we have to make sure that
we parse the correct delimiters while the delimiter
characters could also occur inside the Perl code! */
cps = cpBuf;
while (cps < cpEND) {
if (ePerl_case_sensitive_delimiters)
cpe = strnstr(cps, ePerl_begin_delimiter, cpEND-cps);
else
cpe = strncasestr(cps, ePerl_begin_delimiter, cpEND-cps);
if (cpe == NULL) {
/* there are no more ePerl blocks, so
just encapsulate the remaining contents into
Perl print constructs */
if (cps < cpEND) {
cps2 = cps;
/* first, do all complete lines */
while (cps2 < cpEND && (cpe2 = strnchr(cps2, '\n', cpEND-cps2)) != NULL) {
if (ePerl_line_continuation && cps < cpe2 && *(cpe2-1) == '\\') {
if (cpe2-1-cps2 > 0) {
cpOut = ePerl_fprintf(cpOut, "print \"");
cpOut = ePerl_Efwrite(cps2, cpe2-1-cps2, 1, cpOut);
cpOut = ePerl_fprintf(cpOut, "\";");
}
cpOut = ePerl_fprintf(cpOut, "\n");
}
else {
cpOut = ePerl_fprintf(cpOut, "print \"");
cpOut = ePerl_Efwrite(cps2, cpe2-cps2, 1, cpOut);
cpOut = ePerl_fprintf(cpOut, "\\n\";\n");
}
cps2 = cpe2+1;
}
/* then do the remainder which is not
finished by a newline */
if (cpEND > cps2) {
cpOut = ePerl_fprintf(cpOut, "print \"");
cpOut = ePerl_Efwrite(cps2, cpEND-cps2, 1, cpOut);
cpOut = ePerl_fprintf(cpOut, "\";");
}
}
break; /* and break the whole processing step */
}
else {
/* Ok, there is at least one more ePerl block */
/* first, encapsulate the content from current pos
up to the begin of the ePerl block as print statements */
if (cps < cpe) {
cps2 = cps;
while ((cpe2 = strnchr(cps2, '\n', cpe-cps2)) != NULL) {
if (ePerl_line_continuation && cps < cpe2 && *(cpe2-1) == '\\') {
if (cpe2-1-cps2 > 0) {
cpOut = ePerl_fprintf(cpOut, "print \"");
cpOut = ePerl_Efwrite(cps2, cpe2-1-cps2, 1, cpOut);
cpOut = ePerl_fprintf(cpOut, "\";");
}
cpOut = ePerl_fprintf(cpOut, "\n");
}
else {
cpOut = ePerl_fprintf(cpOut, "print \"");
cpOut = ePerl_Efwrite(cps2, cpe2-cps2, 1, cpOut);
cpOut = ePerl_fprintf(cpOut, "\\n\";\n");
}
cps2 = cpe2+1;
}
if (cpe > cps2) {
cpOut = ePerl_fprintf(cpOut, "print \"");
cpOut = ePerl_Efwrite(cps2, cpe-cps2, 1, cpOut);
cpOut = ePerl_fprintf(cpOut, "\";");
}
}
/* just output a leading space to make
the -x display more readable. */
if (cpOut > cpOutBuf && *(cpOut-1) != '\n')
cpOut = ePerl_fprintf(cpOut, " ");
/* skip the start delimiter */
cps = cpe+strlen(ePerl_begin_delimiter);
/* recognize the 'print' shortcut with '=',
* e.g. <:=$var:>
*/
if (*cps == '=') {
cpOut = ePerl_fprintf(cpOut, "print ");
cps++;
}
/* skip all following whitespaces.
Be careful: we could skip newlines too, but then the
error output will give wrong line numbers!!! */
while (cps < cpEND) {
if (*cps != ' ' && *cps != '\t')
break;
cps++;
}
cpe = cps;
/* move forward to end of ePerl block. */
if (ePerl_case_sensitive_delimiters)
cpe = strnstr(cpe, ePerl_end_delimiter, cpEND-cpe);
else
cpe = strncasestr(cpe, ePerl_end_delimiter, cpEND-cpe);
if (cpe == NULL) {
ePerl_SetError("Missing end delimiter");
CU(NULL);
}
/* step again backward over whitespaces */
for (cpe2 = cpe;
cpe2 > cps && (*(cpe2-1) == ' ' || *(cpe2-1) == '\t' || *(cpe2-1) == '\n');
cpe2--)
;
/* pass through the ePerl block without changes! */
if (cpe2 > cps) {
if (ePerl_convert_entities == TRUE)
cpOut = ePerl_Cfwrite(cps, cpe2-cps, 1, cpOut);
else
cpOut = ePerl_fwrite(cps, cpe2-cps, 1, cpOut);
/* be smart and automatically add a semicolon
if not provided at the end of the ePerl block.
But know the continuation indicator "_". */
if ((*(cpe2-1) != ';') &&
(*(cpe2-1) != '_') )
cpOut = ePerl_fprintf(cpOut, ";");
if (*(cpe2-1) == '_')
cpOut = cpOut - 1;
}
/* end preserve newlines for correct line numbers */
for ( ; cpe2 <= cpe; cpe2++)
if (*cpe2 == '\n')
cpOut = ePerl_fprintf(cpOut, "\n");
/* output a trailing space to make
the -x display more readable when
no newlines have finished the block. */
if (cpOut > cpOutBuf && *(cpOut-1) != '\n')
cpOut = ePerl_fprintf(cpOut, " ");
/* and adjust the current position to the first character
after the end delimiter */
cps = cpe+strlen(ePerl_end_delimiter);
/* finally just one more feature: when an end delimiter
is directly followed by ``//'' this discards all
data up to and including the following newline */
if (cps < cpEND-2 && *cps == '/' && *(cps+1) == '/') {
/* skip characters */
cps += 2;
for ( ; cps < cpEND && *cps != '\n'; cps++)
;
if (cps < cpEND)
cps++;
/* but preserve the newline in the script */
cpOut = ePerl_fprintf(cpOut, "\n");
}
}
}
RETURN_WVAL(cpOutBuf);
CUS:
if (cpOutBuf)
free(cpOutBuf);
RETURN_EXRC;
}
/*
**
** read source file into internal buffer
**
*/
char *ePerl_ReadSourceFile(char *filename, char **cpBufC, int *nBufC)
{
char *rc;
FILE *fp = NULL;
char *cpBuf = NULL;
int nBuf;
char tmpfile[256], *ptr_tmpfile;
int usetmp = 0;
int c;
if (stringEQ(filename, "-")) {
/* file is given on stdin */
ptr_tmpfile = mytmpfile("ePerl.source");
sprintf(tmpfile, "%s", ptr_tmpfile);
if ((fp = fopen(tmpfile, "w")) == NULL) {
ePerl_SetError("Cannot open temporary source file %s for writing", tmpfile);
CU(NULL);
}
nBuf = 0;
while ((c = fgetc(stdin)) != EOF) {
fprintf(fp, "%c", c);
}
fclose(fp);
fp = NULL;
filename = tmpfile;
usetmp = 1;
}
if ((fp = fopen(filename, "r")) == NULL) {
ePerl_SetError("Cannot open source file %s for reading", filename);
CU(NULL);
}
fseek(fp, 0, SEEK_END);
nBuf = ftell(fp);
if (nBuf == 0) {
cpBuf = (char *)malloc(sizeof(char) * 1);
*cpBuf = NUL;
}
else {
if ((cpBuf = (char *)malloc(sizeof(char) * nBuf+1)) == NULL) {
ePerl_SetError("Cannot allocate %d bytes of memory", nBuf);
CU(NULL);
}
fseek(fp, 0, SEEK_SET);
if (fread(cpBuf, nBuf, 1, fp) == 0) {
ePerl_SetError("Cannot read from file %s", filename);
CU(NULL);
}
cpBuf[nBuf] = '\0';
}
*cpBufC = cpBuf;
*nBufC = nBuf;
RETURN_WVAL(cpBuf);
CUS:
if (cpBuf)
free(cpBuf);
if (fp)
fclose(fp);
if (usetmp)
unlink(tmpfile);
RETURN_EXRC;
}
