/* varfuncs.c: -*- C -*-  Functions for the manipulation of variables. */

/*  Copyright (c) 1997 Brian J. Fox
    Author: Brian J. Fox (bfox@ai.mit.edu) Tue Jul 18 17:50:42 1995.

   This file is part of <Meta-HTML>(tm), a system for the rapid deployment
   of Internet and Intranet applications via the use of the Meta-HTML
   language.

   Copyright (c) 1995, 1996, Brian J. Fox (bfox@ai.mit.edu).
   Copyright (c) 1996, Universal Access Inc. (http://www.ua.com).

   Meta-HTML is free software; you can redistribute it and/or modify
   it under the terms of the UAI Free Software License as published
   by Universal Access Inc.; either version 1, 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
   UAI Free Software License for more details.

   You should have received a copy of the UAI Free Software License
   along with this program; if you have not, you may obtain one by
   writing to:

   Universal Access Inc.
   129 El Paseo Court
   Santa Barbara, CA
   93101  */

#include "language.h"

#if defined (__cplusplus)
extern "C"
{
#endif
/************************************************************/
/*							    */
/*		 Variable Manipulation Functions	    */
/*							    */
/************************************************************/

static void pf_set_var (PFunArgs);
static void pf_set_var_verbatim (PFunArgs);
static void pf_set_var_readonly (PFunArgs);
static void pf_get_var (PFunArgs);
static void pf_get_var_once (PFunArgs);
static void pf_binary_concat (PFunArgs);
static void pf_unset_var (PFunArgs);
static void pf_var_exists (PFunArgs);
static void pf_increment (PFunArgs);
static void pf_decrement (PFunArgs);
static void pf_cgi_encode (PFunArgs);
static void pf_cgi_decode (PFunArgs);
static void pf_symbol_info (PFunArgs);
static void pf_copy_var (PFunArgs);
static void pf_coerce_var (PFunArgs);
static void pf_defvar (PFunArgs);
static void pf_alist_p (PFunArgs);
static void pf_alist_merge (PFunArgs);
static void pf_make_alist (PFunArgs);

static PFunDesc func_table[] =
{
  { "SET-VAR-VERBATIM",	0, 0, pf_set_var_verbatim },
  { "SET-VAR",		0, 0, pf_set_var },
  { "SET-VAR-READONLY",	0, 0, pf_set_var_readonly },
  { "GET-VAR",		0, 0, pf_get_var },
  { "GET-VAR-ONCE",	0, 0, pf_get_var_once },
  { "BINARY-CONCAT",	0, 0, pf_binary_concat },
  { "UNSET-VAR",	0, 0, pf_unset_var },
  { "VAR-EXISTS",	0, 0, pf_var_exists },
  { "INCREMENT",	0, 0, pf_increment },
  { "DECREMENT",	0, 0, pf_decrement },
  { "CGI-ENCODE",	0, 0, pf_cgi_encode },
  { "CGI-DECODE",	0, 0, pf_cgi_decode },
  { "SYMBOL-INFO",	0, 0, pf_symbol_info },
  { "COPY-VAR",		0, 0, pf_copy_var },
  { "COERCE-VAR",	0, 0, pf_coerce_var },
  { "DEFVAR",		0, 0, pf_defvar },
  { "ALIST?",		0, 0, pf_alist_p },
  { "ALIST-MERGE",	0, 0, pf_alist_merge },
  { "MAKE-ALIST",	0, 0, pf_make_alist },

  { (char *)NULL,	0, 0, (PFunHandler *)NULL }
};

PACKAGE_INITIALIZER (initialize_variable_functions)
DEFINE_SECTION (VARIABLES, variables; symbols; lookup,
"<Meta-HTML> provides a simple mechanism for the storage and retrieval
of variables during a single (possibly recursive) processing pass.  In
addition to this, functions are provided which test the value of a
variable, and conditionally execute other code based upon the result.

There is also a mechanism to group a set of variables using <secref
packages>.",

"<h3>Variable Types and Information</h3>

There are internal functions in <meta-html> which create <i>binary</i>
variables.  Such variables cannot be used in the ordinary way, since
the data contained within them may not retain integrity once printed
out and read back in.  You can check to see what the type of a
particular variable is with the <funref variables symbol-info>
function.

Many variables are predefined by <Meta-HTML>, and made available to
the page writer.  The <secref Page-Variables> section of this manual
documents those variables fully, while the <secref server-variables>
section contains more information on variables which control, or were
specifically created by, the web server.")

static void
generic_set_variable (Package *vars, int debug_level, int eval_p, int readonly_p)
{
  char *func = (char *)NULL;

  if (readonly_p)
    func =  "set-var-readonly";
  else if (eval_p)
    func = "set-var";
  else
    func = "set-var-verbatim";

  if (vars)
    {
      char **names = get_vars_names (vars);
      char **vals = get_vars_vals (vars);

      if (names != (char **)NULL)
	{
	  register int i;
	  char *sym_name;

	  for (i = 0; (sym_name = names[i]) != (char *)NULL; i++)
	    {
	      char *name = sym_name;
	      char *value = vals[i];
	      int free_value = 0;

	      if (eval_p)
		name = mhtml_evaluate_string (sym_name);

	      if (debug_level >= 5)
		{
		  if (value)
		    page_debug ("<%s \"%s\"=\"%s\">", func, sym_name, value);
		  else
		    page_debug ("<%s \"%s\">", func, sym_name);
		}

	      if (value == (char *)NULL)
		{
		  if (debug_level)
		    page_debug ("<%s %s ...> missing `='", func, sym_name);
		}
	      else
		{
		  if (eval_p)
		    {
		      value = mhtml_evaluate_string (value);
		      if (value) free_value++;
		    }
		}

	      if (debug_level >= 6)
		page_debug ("--> <%s \"%s\"=\"%s\">",
			    func, name ? name : "", value ? value : "");

	      if (name)
		{
		  if (readonly_p)
		    pagefunc_set_variable_readonly (name, value);
		  else
		    pagefunc_set_variable (name, value);
		}

	      if (free_value) free (value);
	      if (name != sym_name) free (name);
	    }
	}
    }
}


DEFUN (pf_set_var, &optional name=value...,
"Gives the variable <var name> the value of <var value> for the
current processing run.  Any number of name/value pairs may be given,
and whitespace is not significant.  Where <var =value> is omitted, the
value is the empty string.

<example>
<set-var foo=bar bar=baz>
<get-var foo>              --> bar
<get-var bar>              --> baz
<get-var <get-var foo>>    --> baz
</example>")
{
  generic_set_variable (vars, debug_level, 1, 0);
}

DEFUN (pf_set_var_verbatim, &optional name=value...,
"Gives the variable <var name> the value of <var value> for the
current processing run.  The difference between
<code>set-var-verbatim</code> and <funref variables set-var> is that
in <code>set-var-verbatim</code> the right-hand side of assignments
are not evaluated.

Example:
<complete-example>
<set-var-verbatim foo=<get-var bar>>
<get-var-once foo>
</complete-example>")
{
  generic_set_variable (vars, debug_level, 0, 0);
}

DEFUN (pf_set_var_readonly, &optional name=value...,
"For each <var name> specified, if that name is not already assigned a
value with <code>set-var-readonly</code>, assigns the associated <var
value> to it, exactly in the way that <funref variables set-var> would.

Once <var name> has had a value assigned to it with
<code>set-var-readonly</code>, then that variable is <i>immutable</i>,
i.e., its value cannot be changed using any Meta-HTML commands.

A useful construct for setting various site specific variables in your
<code>engine.conf</code> or <code>mhttpd.conf</code> file, this allows
one to create globally defined variables which cannot be changed by
the execution of Meta-HTML statements in a page.

Variables which can usefully benefit from this type of setting
include <varref mhtml::include-prefix> and <varref
mhtml::relative-prefix> among others.")
{
  generic_set_variable (vars, debug_level, 1, 1);
}

static void
get_var_internal (PFunArgs, int once)
{
  register int i;
  char *name;

  for (i = 0; (name = get_positional_arg (vars, i)) != (char *)NULL; i++)
    {
      char *insertion = mhtml_evaluate_string (name);
      char *value = pagefunc_get_variable (insertion);

      if (debug_level > 5)
	page_debug ("<get-var \"%s\">", insertion ? insertion : "");

      if (value)
	{
	  int len = strlen (value);
	  bprintf_insert_binary (page, start, value, len);
	  start += len;
	}
      else
	{
	  if (debug_level > 9)
	    page_debug ("<get-var \"%s\">: Unbound Variable \"%s\"!",
			insertion, insertion);
	}

      if (debug_level > 5)
	page_debug ("--> `%s'", value ? value : "");

      xfree (insertion);

      if (once)
	*newstart = start;
    }
}

DEFUN (pf_get_var, &optional name...,
"Return the value of the <var name>s given.  Each <var name> is a
variable name which has had a value assigned to it with <funref
variables set-var>, <funref variables set-var-readonly>, or was
created implicity via <funref packages alist-to-package> or <funref
variables coerce-var>.

The values are returned in the order in which the <var name>s appear.

Examples:
<complete-example>
<set-var foo=Var-1 bar=Var-2>
<get-var foo>, <get-var bar>
</complete-example>

When multiple <var name>s are given:
<complete-example>
<get-var foo bar foo>
</complete-example>")
{
  get_var_internal (PassPFunArgs, 0);
}

DEFUN (pf_get_var_once, &optional name...,
"Returns the current value of the variables named by the <var name>s
given.  The interpreter pointer is then moved to after the returned
data, thus preventing further interpretation of the data.

Example:
<example>
<set-var bar=HELLO>
<set-var-verbatim foo=<get-var bar>>
<get-var-once foo>   --> &lt;get-var bar&gt;
</example>
but...
<example>
<get-var foo>        --> HELLO
</example>")
{
  get_var_internal (PassPFunArgs, 1);
}

DEFUN (pf_unset_var, &optional name...,
"Make <var name>s be non-existent in the page environment.

This is different than <example code><set-var foo=\"\"></example>
because the variable actually ceases to exist, rather than is given no
value.

Example:
<example>
<set-var foo=\"\">
<var-exists foo>      --> true
<get-var foo>         -->
<unset-var foo>
<var-exists foo>      -->
</example>")
{
  register int i;
  char *name;

  for (i = 0; (name = get_positional_arg (vars, i)) != (char *)NULL; i++)
    {
      char *varname = mhtml_evaluate_string (name);
      Symbol *sym = varname ? symbol_lookup (varname) : (Symbol *)NULL;

      if (sym)
	{
	  /* Don't really remove this symbol if it has a notifier
	     attached to it, simply zap the contents. */
	  if (sym->notifier)
	    {
	      register int j;

	      *(sym->notifier) = 0;

	      for (j = 0; j < sym->values_index; j++)
		free (sym->values[j]);

	      if (sym->values_index)
		sym->values[0] = (char *)NULL;

	      sym->values_index = 0;
	    }
	  else if (!symbol_get_flag (sym, sym_READONLY))
	    {
	      sym = symbol_remove (varname);
	      if (sym) symbol_free (sym);
	    }
	}

      xfree (varname);
    }
}

DEFUN (pf_var_exists, name,
"<code>var-exists</code> checks for the <i>existence</i> of
the variable named by <var varname>, and returns <code>true</code> if that
variable exists.

The existence of a variable has nothing to do with its value -- a variable
exists if it has been created with <funref variables set-var>, and doesn't
exist after it has been unset with <funref variables unset-var>.

<example>
  <set-var foo=1 bar>
  <var-exists foo>       --> true
  <var-exists bar>       --> true
  <get-var bar>          -->
  <unset-var foo>
  <var-exists foo>       -->
</example>")
{
  char *arg = mhtml_evaluate_string (get_positional_arg (vars, 0));
  int set_p = 0;

  if (!empty_string_p (arg) && (symbol_lookup (arg) != (Symbol *)NULL))
    set_p++;

  xfree (arg);

  if (set_p)
    {
      bprintf_insert (page, start, "true");
      *newstart += 4;
    }
}

DEFUN (pf_binary_concat, collector &rest binary-vars,
"Concatenate the contents of <var collector> and the supplied <var binary-var>s
into a single binary variable, and store the results back in <var collector>.")
{
  register int i = 0;
  char *collector_name = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (!empty_string_p (collector_name))
    {
      BPRINTF_BUFFER *buf = bprintf_create_buffer ();
      char *varname;

      while ((varname = mhtml_evaluate_string (get_positional_arg (vars, i))))
	{
	  i++;

	  if (!empty_string_p (varname))
	    {
	      Symbol *sym = symbol_lookup (varname);

	      if ((sym != (Symbol *)NULL) && sym->type == symtype_BINARY)
		{
		  Datablock *b = (Datablock *)sym->values;

		  bprintf_insert_binary (buf, buf->bindex, b->data, b->length);
		}
	    }
	  free (varname);
	}

      {
	Symbol *collector = (Symbol *)NULL;
	Symbol *remsym = symbol_remove (collector_name);
	Datablock *b = datablock_create (buf->buffer, buf->bindex);

	symbol_free (remsym);
	collector = symbol_intern (collector_name);
	collector->type = symtype_BINARY;
	collector->values = (char **)b;
      }

      bprintf_free_buffer (buf);
    }

  xfree (collector_name);
}

static void
change_increment (PFunArgs, int default_amount)
{
  char *var_name = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (!empty_string_p (var_name))
    {
      char *var_value = pagefunc_get_variable (var_name);
      char *incr = get_one_of (vars, "BY", "AMOUNT", (char *)NULL);
      double value = 0.0;
      double amount = (double)default_amount;
      static char number[40];
      int dot_present = 0;

      if (var_value != (char *)NULL)
	{
	  dot_present = (strchr (var_value, '.') != (char *)NULL);
	  value = strtod (var_value, (char **)NULL);
	}

      if (!empty_string_p (incr))
	{
	  incr = mhtml_evaluate_string (incr);
	  if (incr)
	    {
	      if (!dot_present)
		dot_present = (strchr (incr, '.') != (char *)NULL);
	      amount = default_amount * strtod (incr, (char **)NULL);
	      free (incr);
	    }
	}

      value += amount;
      if (dot_present)
	sprintf (number, "%.2f", value);
      else
	sprintf (number, "%ld", (long)value);

      pagefunc_set_variable (var_name, number);
    }

  xfree (var_name);
}

DEFUN (pf_increment, name &key by=amount,
"Add <var amount> (default 1) to the contents of the variable named by
<var varname>.

<example>
<set-var foo=1>
<get-var foo> --> 1
<increment foo>
<get-var foo> --> 2
</example>

Also see <funref variables decrement>.")
{
  change_increment (PassPFunArgs, 1);
}

DEFUN (pf_decrement, name &key by=amount,
"Subtract <var amount> (default 1) from the contents of the variable named
by <var varname>.

<example>
   <set-var foo=1>
   <get-var foo> --> 1
   <decrement foo>
   <get-var foo> --> 0
</example>

Also see <funref variables increment>.")
{
  change_increment (PassPFunArgs, -1);
}

DEFUN (pf_cgi_encode, &rest vars &key preserve-case=true strip=true,
"A CGI readable string is created from the names of the <var var>s given,
and the associated values of those variables.  For example, if the
variable <code>FOO-VAR</code> has the value <code>\"Foo &
Value\"</code>, then the invocation
<set-var foo-var=\"Foo & Value\">
<complete-example>
<cgi-encode FOO-VAR>
</complete-example>

Given the optional keyword argument of <var preserve-case=true>,
<code>cgi-encode</code> encodes the variables preserving the case of
them as they were input.

<complete-example>
<cgi-encode Foo-Var preserve-case=true>
</complete-example>

Finally, the keyword flag <var strip=true>, when present, says to
strip off the package name of each variable before placing it in an
assignment statement (also see <funref packages package-vars>).

<complete-example>
<set-var FOO::BAR=value>
<cgi-encode Foo::Bar preserve-case=true strip=true>
</complete-example>")
{
  char **names = get_vars_names (vars);

  if (names != (char **)NULL)
    {
      register int i;
      char *name;
      char *result = (char *)NULL;
      Package *cgivars = symbol_get_package ((char *)NULL);
      Symbol **symbols = (Symbol **)NULL;
      int save_case_p = 0;
      int strip_package = 0;

      {
	char *temp = mhtml_evaluate_string (get_value (vars, "preserve-case"));
	if (!empty_string_p (temp)) save_case_p++;
	temp = mhtml_evaluate_string (get_value (vars, "strip"));
	if (!empty_string_p (temp)) strip_package++;
      }

      for (i = 0; (name = names[i]) != (char *)NULL; i++)
	{
	  name = mhtml_evaluate_string (name);

	  if (!empty_string_p (name))
	    {
	      Symbol *sym = symbol_lookup (name);
	      if ((sym != (Symbol *)NULL) && (sym->type == symtype_STRING))
		{
		  register int j;
		  Symbol *newsym;

		  if (strip_package)
		    {
		      char *tempname = strstr (name, "::");
		      if (tempname)
			{
			  tempname = strdup (tempname + 2);
			  free (name);
			  name = tempname;
			}
		    }

		  newsym = symbol_intern_in_package (cgivars, name);

		  if (save_case_p)
		    newsym->preserved_name = strdup (name);

		  for (j = 0; j < sym->values_index; j++)
		    symbol_add_value (newsym, sym->values[j]);
		}
	    }

	  xfree (name);
	}

      symbols = symbols_of_package (cgivars);
      result = forms_unparse_items (symbols);

      if (!empty_string_p (result))
	{
	  bprintf_insert (page, start, "%s", result);
	  *newstart = start + strlen (result);
	}

      if (result) free (result);
      if (symbols) free (symbols);
      symbol_destroy_package (cgivars);
    }
}

DEFUN (pf_cgi_decode, string &optional package,
"Decode <var string> into <var package>.

If <var package> is not specified the current package is used.

<var string> is a string that might have appeared in
<code>QUERY_STRING</code> or the contents of the data that was posted
to a document, such that it consists of name value pairs:

<example>
FOO=bar&STRING=this+is+a+string%2C+other+chars
</example>

<var package> is the name of a package to bind the variables in.  So,
given the above example as the text in a variable called <var string>,
here is what you get:

<complete-example>
<set-var string=\"FOO=bar&STRING=a+string%2C+other+chars\">
<cgi-decode <get-var string> mypack>
<get-var mypack::string>
</complete-example>

Also see <funref variables cgi-encode>.")
{
  char *string, *packname = (char *)NULL;
  char *temp;
  Package *package = CurrentPackage;
  int offset = 0;

  string = read_sexp (body->buffer, &offset, 0);
  packname = read_sexp (body->buffer, &offset, 0);

  if (string != (char *)NULL)
    {
      temp = mhtml_evaluate_string (string);
      free (string);
      string = temp;
    }

  if (!empty_string_p (string))
    {
      if (packname != (char *)NULL)
	{
	  temp = mhtml_evaluate_string (packname);
	  free (packname);
	  packname = temp;

	  if (!empty_string_p (packname))
	    package = symbol_get_package (packname);

	  if (packname != (char *)NULL)
	    free (packname);
	}

      forms_parse_data_string (string, package);
    }

  if (string != (char *)NULL)
    free (string);
}

DEFUN (pf_symbol_info, symbol,
"Returns information about the symbol <var symbol>.

The information is two lines:

<ul>
<li> The type of the symbol, which is one of:
<ol>
<li><code>STRING</code>,
<li><code>BINARY</code>,
<li><code>USER DEFUN</code>,
<li><code>USER SUBST</code>,
<li><code>USER MACRO</code>,
<li><code>PRIM DEFUN</code>, or
<li><code>PRIM MACRO</code>.
</ol>
<li> The \"size\" of the symbol.
</ul>

For <code>STRING</code>. variables, the size value is the number of
elements in the array.<br>
For BINARY variables, the size value is the number of bytes of binary
data stored within.

The size value is zero for all other variable types.")
{
  char *name = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (name)
    {
      Symbol *sym = symbol_lookup (name);

      if (sym != (Symbol *)NULL)
	{
	  switch (sym->type)
	    {
	    case symtype_STRING:
	      bprintf_insert (page, start, "STRING\n%d", sym->values_index);
	      break;

	    case symtype_FUNCTION:
	      {
		PFunDesc *desc = (PFunDesc *)sym->values;
		if (desc->complexp)
		  bprintf_insert (page, start, "PRIM MACRO\n0");
		else
		  bprintf_insert (page, start, "PRIM DEFUN\n0");
	      }
	      break;

	    case symtype_BINARY:
	      bprintf_insert (page, start, "BINARY\n%d",
			      ((Datablock *)sym->values)->length);
	      break;

	    case symtype_USERFUN:
	      {
		switch (((UserFunction *)sym->values)->type)
		  {
		  case user_MACRO:
		    bprintf_insert (page, start, "USER MACRO\n0");
		    break;
		  case user_SUBST:
		    bprintf_insert (page, start, "USER SUBST\n0");
		    break;
		  case user_DEFUN:
		    bprintf_insert (page, start, "USER DEFUN\n0");
		    break;
		  }
	      }
	    break;
	    }
	}
      free (name);
    }
}

DEFUN (pf_copy_var, from-var &optional to-var...,
"Copies the variable <var from-var> to each of the named <var to-var>s.

Each <var to-var> becomes the repository of a copy of the information
already stored under <var from-var>.  This is a <i>true</i> copy; not
an alias to the original variable.

<example>
<set-var foo=bar>
<get-var foo>      --> bar
<get-var new>      --> 
<copy-var foo new> -->
<get-var new>      --> bar

<copy-var *meta-html*::get-var *meta-html*::foo>
<foo new>          --> bar
</example>")
{
  char *source_name = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (!empty_string_p (source_name))
    {
      Symbol *source = symbol_lookup (source_name);

      if (source != (Symbol *)NULL)
	{
	  register int i = 1;
	  char *dest_name = (char *)NULL;
	  int done = 0;

	  while (!done)
	    {
	      dest_name = mhtml_evaluate_string (get_positional_arg (vars, i));
	      i++;

	      if (dest_name == (char *)NULL)
		{
		  done = 1;
		  continue;
		}

	      if (debug_level > 5)
		page_debug ("--><copy-var %s %s>", source_name, dest_name);

	      if (!empty_string_p (dest_name))
		{
		  Symbol *dest = symbol_intern (dest_name);

		  if (dest != source)
		    {
		      Package *temp = symbol_get_package ((char *)NULL);
		      Symbol *copy = symbol_copy (source, temp);

		      copy = symbol_rename (copy, dest->name);
		      symbol_move (copy, (Package *)dest->package);
		      symbol_destroy_package (temp);
		    }
		}
	      free (dest_name);
	    }
	}
    }

  xfree (source_name);
}

#if !defined (symtype_ARRAY)
#define symtype_ARRAY 78
#endif
DEFUN (pf_coerce_var, varname &key type=(STRING|BINARY|ARRAY),
"Coerces <var varname>'s data to have the type specified by the
argument to <var type>.  You can convert a binary object to a string
object, and vice-versa.

A binary variable might be created as the result of a call to <funref
stream-commands stream-get-contents>, for example.  Once the data is
read, you might wish to perform some substitutions on it, or otherwise
get its value.  To do so, you call <code>coerce-var</code> on the
value:

<example>
<with-open-stream s /tmp/file mode=read>
  <stream-get-contents s foo>
</with-open-stream>

<coerce-var foo type=string>
<subst-in-string <get-var foo> \"Hello\" \"Goodbye\">
<get-var foo>
</example>")
{
  char *source_name = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (!empty_string_p (source_name))
    {
      Symbol *source;

      source = symbol_lookup (source_name);

      if (source != (Symbol *)NULL)
	{
	  int dest_type = -1;

	  {
	    char *type_name = mhtml_evaluate_string (get_value (vars, "type"));

	    if (!empty_string_p (type_name))
	      {
		if (strcasecmp (type_name, "binary") == 0)
		  dest_type = symtype_BINARY;
		else if (strcasecmp (type_name, "string") == 0)
		  dest_type = symtype_STRING;
		else if (strcasecmp (type_name, "array") == 0)
		  dest_type = symtype_ARRAY;
	      }

	    if (type_name != (char *)NULL) free (type_name);
	  }

	  if ((source->type != dest_type) && (dest_type != -1))
	    {
	      /* Do the coercion. */
	      switch (dest_type)
		{
		case symtype_ARRAY:
		  {
		    if (source->type == symtype_BINARY)
		      {
			Datablock *block = (Datablock *)source->values;
			char *data = (char *)xmalloc (2 + block->length);

			memcpy (data, block->data, block->length);
			data[block->length] = '\0';
			free (block->data);
			free (block);
			source->values_index = 1;
			source->values_slots = 2;
			source->values =(char **)xmalloc (2 * sizeof (char *));
			source->values[0] = data;
			source->values[1] = (char *)NULL;
			source->type = symtype_STRING;
		      }

		    if ((source->type == symtype_STRING) &&
			(source->values_index == 1))
		      {
			/* Make each line of the source (including blanks)
			   be a single element in the destination array. */
			register int i, beg;
			int dst_index  = 0, dst_slots = 0;
			char **array = (char **)NULL;
			char *string = source->values[0];

			beg = 0; i = 0;
			while (string[beg] != '\0')
			  {
			    /* Find end of line, or end of data. */
			    for (i = beg;
				 ((string[i] != '\0') && (string[i] != '\n'));
				 i++);

			    if ((beg == i) && (string[i] == '\0'))
			      break;
			    else
			      {
				int size = i - beg;
				char *line = (char *)xmalloc (1 + size);
				strncpy (line, string + beg, size);
				line[size] = '\0';

				if (dst_index + 2 > dst_slots)
				  array = (char **)xrealloc
				    (array, (dst_slots += 10)
				     * sizeof (char *));

				array[dst_index++] = line;
				array[dst_index] = (char *)NULL;
				if (string[i]) i++;
				beg = i;
			      }
			  }

			symbol_store_array (source_name, array);
		      }
		  }
		break;

		case symtype_STRING:
		  switch (source->type)
		    {
		    case symtype_STRING:
		    case symtype_FUNCTION:
		      break;

		    case symtype_BINARY:
		      {
			Datablock *block = (Datablock *)source->values;
			char *data = (char *)xmalloc (2 + block->length);

			memcpy (data, block->data, block->length);
			data[block->length] = '\0';
			free (block->data);
			free (block);
			source->values_index = 1;
			source->values_slots = 2;
			source->values =
			  (char **)xmalloc (2 * sizeof (char *));
			source->values[0] = data;
			source->values[1] = (char *)NULL;
			source->type = symtype_STRING;
		      }
		      break;
		    }
		  break;

		case symtype_BINARY:
		  switch (source->type)
		    {
		    case symtype_BINARY:
		    case symtype_FUNCTION:
		      break;

		    case symtype_STRING:
		      {
			register int i;
			Datablock *block;
			BPRINTF_BUFFER *buffer;
			  
			block = (Datablock *)xmalloc (sizeof (Datablock));
			buffer = bprintf_create_buffer ();
			
			for (i = 0; i < source->values_index; i++)
			  {
			    bprintf (buffer, "%s%s",
				     i != 0 ? "\n" : "", source->values[i]);
			    free (source->values[i]);
			  }
			  
			block->data = buffer->buffer;
			block->length = buffer->bindex;
			free (buffer);
			free (source->values);
			source->values_index = 0;
			source->values = (char **)block;
			source->type = symtype_BINARY;
		      }
		      break;
		    }
		  break;
		}
	    }
	}
    }

  if (source_name != (char *)NULL) free (source_name);
}

DEFUN (pf_defvar, name value,
"<b>DEF</b>ault the value of the <b>VAR</b>iable named by <var name>
to <var value>.

<code>defvar</code> assigns <var value> to <var name> if, and only if,
<var name> has a non-empty value.

<code>defvar</code> could have been defined in <Meta-HTML> using
<funref macro-commands define-tag>:

<example>
<define-tag defvar var val>
  <if <not <get-var var>> <set-var <get-var var>=<get-var val>>>
</define-tag>
</example>")
{
  char *name = mhtml_evaluate_string (get_positional_arg (vars, 0));

  if (!empty_string_p (name))
    {
      char *current_value = pagefunc_get_variable (name);

      if (empty_string_p (current_value))
	{
	  char *new_value;

	  new_value = mhtml_evaluate_string (get_positional_arg (vars, 1));
	  if (!empty_string_p (new_value))
	    pagefunc_set_variable (name, new_value);

	  if (new_value) free (new_value);
	}
    }

  xfree (name);
}

DEFUNX (pf_alist?, string,
"Return \"t\" if <var string> is a representation of an association list.")

static void
pf_alist_p (PFunArgs)
{
  char *string = mhtml_evaluate_string (get_positional_arg (vars, 0));
  WispObject *list = string ? wisp_from_string (string) : NIL;
  int is_alist = 0;

  if ((CONS_P (list)) &&
      (list != NIL) &&
      (CONS_P (CAR (list))) &&
      (STRING_P (CAR (CAR (list)))))
    is_alist++;

  gc_wisp_objects ();
  xfree (string);

  if (is_alist)
    {
      bprintf_insert (page, start, "t");
      *newstart = *newstart + 1;
    }
}

DEFUN (pf_alist_merge, &rest alist-vars &key strip append,
"Merge the alists stored in the passed variable names into a single alist,
and return that new alist.

By default, each <var alist-var> encountered overrides values set in
previous alists that were encountered -- the values do not \"pile up\" --
they instead replace each other.

Passing the keyword argument <var append=true> changes this behavior; in
this case values seen in subsequent alists are appended to the values in
previous alists, creating array variables in the output.
<complete-example>
<set-var a1=<make-alist foo=foo1 bar=bar1>
         a2=<make-alist foo=foo2 newvar=newval>>
<alist-merge a1 a2>
<alist-merge a1 a2 append=true>
</complete-example>")
{
  register int i;
  Package *p = symbol_get_package ((char *)NULL);
  char *varname = (char *)NULL;
  char *result = (char *)NULL;
  char *strip_arg = mhtml_evaluate_string (get_value (vars, "strip"));
  char *append_arg = mhtml_evaluate_string (get_value (vars, "append"));
  int stripping = (!empty_string_p (strip_arg));
  int appending = (!empty_string_p (append_arg));

  xfree (strip_arg);
  xfree (append_arg);

  for (i = 0;
       (varname = mhtml_evaluate_string (get_positional_arg (vars, i))) != 
	 (char *)NULL;
       i++)
    {
      if (!empty_string_p (varname))
	{
	  char *val = pagefunc_get_variable (varname);

	  if (!empty_string_p (val))
	    {
	      Package *this_alist = alist_to_package (val);

	      if (appending)
		{
		  Symbol **newsyms = symbols_of_package (this_alist);

		  if (newsyms != (Symbol **)NULL)
		    {
		      register int j;
		      Symbol *sym;

		      for (j = 0; (sym = newsyms[j]) != (Symbol *)NULL; j++)
			{
			  register int symi;
			  Symbol *appendsym;

			  appendsym = symbol_intern_in_package (p, sym->name);

			  for (symi = 0; symi < sym->values_index; symi++)
			    symbol_add_value (appendsym, sym->values[symi]);
			}
		    }
		}
	      else
		{
		  symbol_copy_package (this_alist, p);
		  symbol_destroy_package (this_alist);
		}
	    }
	}

      xfree (varname);
      varname = (char *)NULL;
    }

  result = package_to_alist (p, stripping);
  symbol_destroy_package (p);

  if (!empty_string_p (result))
    {
      bprintf_insert (page, start, "%s", result);
      *newstart += strlen (result);
    }

  xfree (result);
}

DEFUN (pf_make_alist, &rest name-value-pairs,
"Return an alist from the <var name-value> pairs passed.
<complete-example>
 <make-alist foo=bar baz=this>
</complete-example>")
{
  BPRINTF_BUFFER *expr = bprintf_create_buffer ();
  char *result = (char *)NULL;

  bprintf (expr, "<with __alist__=\"\">");
  bprintf (expr, "<alist-set-var __alist__ %s>", body->buffer);
  bprintf (expr, "<get-var-once __alist__></with>");
  result = mhtml_evaluate_string (expr->buffer);
  bprintf_free_buffer (expr);

  if (result != (char *)NULL)
    {
      bprintf_insert (page, start, "%s", result);
      *newstart += strlen (result);
      free (result);
    }
}

#if defined (__cplusplus)
}
#endif
