wrappers/pl_Template.ml

   1 (** Wrapper around Perl [Template] class (Template Toolkit). *)
   2 (*  Copyright (C) 2003 Dave Benjamin <dave@3dex.com>.
   3
   4     This library is free software; you can redistribute it and/or
   5     modify it under the terms of the GNU Library General Public
   6     License as published by the Free Software Foundation; either
   7     version 2 of the License, or (at your option) any later version.
   8
   9     This library is distributed in the hope that it will be useful,
  10     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12     Library General Public License for more details.
  13
  14     You should have received a copy of the GNU General Public License
  15     along with this library; see the file COPYING.  If not, write to
  16     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  17     Boston, MA 02111-1307, USA.
  18
  19     $Id: pl_Template.ml,v 1.3 2008-03-01 13:02:21 rich Exp $
  20   *)
  21
  22 open Perl
  23
  24 let _ = eval "use Template"
  25
  26 exception Not_implemented
  27 exception Error of string
  28
  29 module Variant =
  30
  31 struct
  32
  33   type t =
  34     | Null
  35     | String of string
  36     | Int of int
  37     | Float of float
  38     | Bool of bool
  39     | Array of t list
  40     | Hash of (string * t) list;;
  41
  42 end
  43
  44 let rec sv_of_variant = function
  45   | Variant.Null -> sv_undef ()
  46   | Variant.String s -> sv_of_string s
  47   | Variant.Int i -> sv_of_int i
  48   | Variant.Float f -> sv_of_float f
  49   | Variant.Bool b -> sv_of_bool b
  50   | Variant.Array xs -> arrayref (av_of_sv_list (List.map sv_of_variant xs))
  51   | Variant.Hash xs -> hashref
  52       (let hv = hv_empty () in
  53          List.iter (fun (k, v) -> hv_set hv k (sv_of_variant v)) xs;
  54          hv
  55       );;
  56
  57 let hv_of_string_pair_list pairs =
  58   let hv = hv_empty () in
  59     List.iter (fun (k, v) -> hv_set hv k (sv_of_string v)) pairs;
  60     hv
  61
  62 class template sv =
  63
  64 object (self)
  65
  66   method process file vars =
  67     let output = sv_of_string "" in
  68     let args = [sv_of_string file; sv_of_variant vars; scalarref output] in
  69     let result = call_method sv "process" args in
  70       if not (sv_is_true result) then
  71         raise (Error self#error)
  72       else
  73         string_of_sv output
  74
  75   method error =
  76     string_of_sv (call_method sv "error" [])
  77
  78 end
  79
  80 let may f = function None -> () | Some v -> f v
  81
  82 let new_ ?start_tag ?end_tag ?tag_style ?pre_chomp ?post_chomp ?trim
  83   ?interpolate ?anycase ?include_path ?delimiter ?absolute ?relative
  84   ?default ?blocks ?auto_reset ?recursion ?variables ?constants
  85   ?constant_namespace ?namespace ?pre_process ?post_process ?process
  86   ?wrapper ?error ?errors ?eval_perl ?output ?output_path ?debug ?debug_format
  87   ?cache_size ?compile_ext ?compile_dir ?plugins ?plugin_base ?load_perl
  88   ?filters ?v1dollar ?load_templates ?load_plugins ?load_filters
  89   ?tolerant ?service ?context ?stash ?parser ?grammar () =
  90
  91   let args = ref [] in
  92     may (fun v ->
  93            args := sv_of_string "START_TAG" :: sv_of_string v :: !args) start_tag;
  94     may (fun v ->
  95            args := sv_of_string "END_TAG" :: sv_of_string v :: !args) end_tag;
  96     may (fun v ->
  97            args := sv_of_string "TAG_STYLE" :: sv_of_string v :: !args) tag_style;
  98     may (fun v ->
  99            args := sv_of_string "PRE_CHOMP" :: sv_of_bool v :: !args) pre_chomp;
 100     may (fun v ->
 101            args := sv_of_string "POST_CHOMP" :: sv_of_bool v :: !args) post_chomp;
 102     may (fun v ->
 103            args := sv_of_string "TRIM" :: sv_of_bool v :: !args) trim;
 104     may (fun v ->
 105            args := sv_of_string "INTERPOLATE" :: sv_of_bool v :: !args) interpolate;
 106     may (fun v ->
 107            args := sv_of_string "ANYCASE" :: sv_of_bool v :: !args) anycase;
 108     may (fun v ->
 109            args := sv_of_string "INCLUDE_PATH" :: arrayref (av_of_string_list v) :: !args) include_path;
 110     may (fun v ->
 111            args := sv_of_string "DELIMITER" :: sv_of_string v :: !args) delimiter;
 112     may (fun v ->
 113            args := sv_of_string "ABSOLUTE" :: sv_of_bool v :: !args) absolute;
 114     may (fun v ->
 115            args := sv_of_string "RELATIVE" :: sv_of_bool v :: !args) relative;
 116     may (fun v ->
 117            args := sv_of_string "DEFAULT" :: sv_of_string v :: !args) default;
 118     may (fun v ->
 119            args := sv_of_string "BLOCKS" :: hashref (hv_of_string_pair_list v) :: !args) blocks;
 120     may (fun v ->
 121            args := sv_of_string "AUTO_RESET" :: sv_of_bool v :: !args) auto_reset;
 122     may (fun v ->
 123            args := sv_of_string "RECURSION" :: sv_of_bool v :: !args) recursion;
 124     may (fun v ->
 125            args := sv_of_string "VARIABLES" :: sv_of_variant v :: !args) variables;
 126     may (fun v ->
 127            args := sv_of_string "CONSTANTS" :: sv_of_variant v :: !args) constants;
 128     may (fun v ->
 129            args := sv_of_string "CONSTANT_NAMESPACE" :: sv_of_string v :: !args) constant_namespace;
 130     may (fun v ->
 131            args := sv_of_string "NAMESPACE" :: sv_of_variant v :: !args) namespace;
 132     may (fun v ->
 133            args := sv_of_string "PRE_PROCESS" :: arrayref (av_of_string_list v) :: !args) pre_process;
 134     may (fun v ->
 135            args := sv_of_string "POST_PROCESS" :: arrayref (av_of_string_list v) :: !args) post_process;
 136     may (fun v ->
 137            args := sv_of_string "PROCESS" :: arrayref (av_of_string_list v) :: !args) process;
 138     may (fun v ->
 139            args := sv_of_string "WRAPPER" :: arrayref (av_of_string_list v) :: !args) wrapper;
 140     may (fun v ->
 141            args := sv_of_string "ERROR" :: sv_of_string v :: !args) error;
 142     may (fun v ->
 143            args := sv_of_string "ERRORS" :: hashref (hv_of_string_pair_list v) :: !args) errors;
 144     may (fun v ->
 145            args := sv_of_string "EVAL_PERL" :: sv_of_bool v :: !args) eval_perl;
 146     may (fun v ->
 147            raise Not_implemented) output;
 148     may (fun v ->
 149            raise Not_implemented) output_path;
 150     may (fun v ->
 151            args := sv_of_string "DEBUG" :: sv_of_string v :: !args) debug;
 152     may (fun v ->
 153            args := sv_of_string "DEBUG_FORMAT" :: sv_of_string v :: !args) debug_format;
 154     may (fun v ->
 155            args := sv_of_string "CACHE_SIZE" :: sv_of_int v :: !args) cache_size;
 156     may (fun v ->
 157            args := sv_of_string "COMPILE_EXT" :: sv_of_string v :: !args) compile_ext;
 158     may (fun v ->
 159            args := sv_of_string "COMPILE_DIR" :: sv_of_string v :: !args) compile_dir;
 160     may (fun v ->
 161            args := sv_of_string "PLUGINS" :: hashref (hv_of_string_pair_list v) :: !args) plugins;
 162     may (fun v ->
 163            args := sv_of_string "PLUGIN_BASE" :: arrayref (av_of_string_list v) :: !args) plugin_base;
 164     may (fun v ->
 165            args := sv_of_string "LOAD_PERL" :: sv_of_bool v :: !args) load_perl;
 166     may (fun v ->
 167            raise Not_implemented) filters;
 168     may (fun v ->
 169            args := sv_of_string "V1DOLLAR" :: sv_of_bool v :: !args) v1dollar;
 170     may (fun v ->
 171            raise Not_implemented) load_templates;
 172     may (fun v ->
 173            raise Not_implemented) load_plugins;
 174     may (fun v ->
 175            raise Not_implemented) load_filters;
 176     may (fun v ->
 177            args := sv_of_string "TOLERANT" :: sv_of_bool v :: !args) tolerant;
 178     may (fun v ->
 179            raise Not_implemented) service;
 180     may (fun v ->
 181            raise Not_implemented) context;
 182     may (fun v ->
 183            raise Not_implemented) stash;
 184     may (fun v ->
 185            raise Not_implemented) parser;
 186     may (fun v ->
 187            raise Not_implemented) grammar;
 188     let sv = call_class_method "Template" "new" !args in
 189       new template sv