perl.cmo: perl.cmi
perl.cmx: perl.cmi
+perl_init.cmo: perl.cmi
+perl_init.cmx: perl.cmx
+examples/loadpage.cmo: perl.cmi wrappers/pl_HTML_Element.cmo \
+ wrappers/pl_HTML_TreeBuilder.cmo wrappers/pl_HTTP_Request.cmo \
+ wrappers/pl_LWP_UserAgent.cmo
+examples/loadpage.cmx: perl.cmx wrappers/pl_HTML_Element.cmx \
+ wrappers/pl_HTML_TreeBuilder.cmx wrappers/pl_HTTP_Request.cmx \
+ wrappers/pl_LWP_UserAgent.cmx
examples/test.cmo: perl.cmi
examples/test.cmx: perl.cmx
+wrappers/pl_HTML_Element.cmo: perl.cmi
+wrappers/pl_HTML_Element.cmx: perl.cmx
+wrappers/pl_HTML_Parser.cmo: perl.cmi
+wrappers/pl_HTML_Parser.cmx: perl.cmx
+wrappers/pl_HTML_TreeBuilder.cmo: perl.cmi wrappers/pl_HTML_Element.cmo \
+ wrappers/pl_HTML_Parser.cmo
+wrappers/pl_HTML_TreeBuilder.cmx: perl.cmx wrappers/pl_HTML_Element.cmx \
+ wrappers/pl_HTML_Parser.cmx
+wrappers/pl_HTTP_Message.cmo: perl.cmi
+wrappers/pl_HTTP_Message.cmx: perl.cmx
+wrappers/pl_HTTP_Request.cmo: perl.cmi wrappers/pl_HTTP_Message.cmo \
+ wrappers/pl_URI.cmo
+wrappers/pl_HTTP_Request.cmx: perl.cmx wrappers/pl_HTTP_Message.cmx \
+ wrappers/pl_URI.cmx
+wrappers/pl_HTTP_Response.cmo: perl.cmi wrappers/pl_HTTP_Message.cmo
+wrappers/pl_HTTP_Response.cmx: perl.cmx wrappers/pl_HTTP_Message.cmx
+wrappers/pl_LWP_UserAgent.cmo: perl.cmi wrappers/pl_HTTP_Request.cmo \
+ wrappers/pl_HTTP_Response.cmo
+wrappers/pl_LWP_UserAgent.cmx: perl.cmx wrappers/pl_HTTP_Request.cmx \
+ wrappers/pl_HTTP_Response.cmx
+wrappers/pl_URI.cmo: perl.cmi
+wrappers/pl_URI.cmx: perl.cmx
Makefile.config
MANIFEST
examples/.cvsignore
+examples/loadpage.ml
examples/TestClass.pm
examples/test.ml
examples/test.pl
perl.ml
perl.mli
-perl_c.c
\ No newline at end of file
+perl_c.c
+perl_init.ml
+wrappers/.cvsignore
+wrappers/pl_HTML_Element.ml
+wrappers/pl_HTML_Parser.ml
+wrappers/pl_HTML_TreeBuilder.ml
+wrappers/pl_HTTP_Message.ml
+wrappers/pl_HTTP_Request.ml
+wrappers/pl_HTTP_Response.ml
+wrappers/pl_LWP_UserAgent.ml
+wrappers/pl_URI.ml
\ No newline at end of file
# Interface to Perl from OCaml.
# Copyright (C) 2003 Merjis Ltd.
-# $Id: Makefile,v 1.5 2003-10-12 12:14:06 rich Exp $
+# $Id: Makefile,v 1.6 2003-10-12 17:33:14 rich Exp $
include Makefile.config
OCAMLMKLIB := ocamlmklib
OCAMLDEP := ocamldep
-OCAMLCFLAGS := -w s -g
-OCAMLOPTFLAGS := -w s
+OCAMLCINCS := -I wrappers
+OCAMLOPTINCS := $(OCAMLCINCS)
+
+OCAMLCFLAGS := -w s -g $(OCAMLCINCS)
+OCAMLOPTFLAGS := -w s $(OCAMLOPTINCS)
CC := gcc
CFLAGS := -Wall -Wno-unused -I$(PERLINCDIR)
-all: perl.cma perl.cmxa examples/test
+WRAPPERS := \
+ wrappers/pl_HTML_Element.cmo \
+ wrappers/pl_HTML_Parser.cmo \
+ wrappers/pl_HTML_TreeBuilder.cmo \
+ wrappers/pl_URI.cmo \
+ wrappers/pl_HTTP_Message.cmo \
+ wrappers/pl_HTTP_Request.cmo \
+ wrappers/pl_HTTP_Response.cmo \
+ wrappers/pl_LWP_UserAgent.cmo
+
+all: perl.cma perl.cmxa perl_init.cmo perl_init.cmx all-examples
-perl.cma: perl.cmo perl_c.o
+perl.cma: perl.cmo perl_c.o $(WRAPPERS)
$(OCAMLMKLIB) -o perl $^ -lperl
-perl.cmxa: perl.cmx perl_c.o
+perl.cmxa: perl.cmx perl_c.o $(WRAPPERS:.cmo=.cmx)
$(OCAMLMKLIB) -o perl $^ -lperl
-examples/test: examples/test.ml
- $(OCAMLC) $(OCAMLCFLAGS) perl.cma $^ -o $@
+all-examples: examples/test examples/loadpage
+
+examples/test: examples/test.cmo
+ $(OCAMLC) $(OCAMLCFLAGS) perl.cma perl_init.cmo $^ -o $@
+
+#examples/test.opt: examples/test.cmx
+# $(OCAMLOPT) $(OCAMLOPTFLAGS) perl.cmxa perl_init.cmx $^ -o $@
+
+examples/loadpage: examples/loadpage.cmo
+ $(OCAMLC) $(OCAMLCFLAGS) perl.cma perl_init.cmo $^ -o $@
+
+#examples/loadpage.opt: examples/loadpage.cmx
+# $(OCAMLOPT) $(OCAMLOPTFLAGS) perl.cmxa perl_init.cmx $^ -o $@
%.cmi: %.mli
$(OCAMLC) $(OCAMLCFLAGS) -c $<
JUNKFILES = core *~ *.bak *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so
clean:
- rm -f examples/test
- for d in . examples; do (cd $$d; rm -f $(JUNKFILES)); done
+ rm -f examples/test examples/loadpage
+ for d in . examples wrappers; do (cd $$d; rm -f $(JUNKFILES)); done
# Build dependencies.
depend: .depend
-.depend: $(wildcard *.ml) $(wildcard *.mli)
- $(OCAMLDEP) *.mli *.ml examples/*.ml > .depend
+.depend: $(wildcard *.ml) $(wildcard *.mli) $(wildcard examples/*.ml) \
+ $(wildcard wrappers/*.ml)
+ $(OCAMLDEP) $(OCAMLCINCS) *.mli *.ml examples/*.ml wrappers/*.ml \
+ > .depend
# Install.
install -c -m 0755 -d $(OCAMLLIBDIR)
install -c -m 0755 -d $(OCAMLLIBDIR)/stublibs
install -c -m 0644 perl.cmi perl.mli perl.cma perl.cmxa $(OCAMLLIBDIR)
+ install -c -m 0644 perl_init.cmo perl_init.cmx $(OCAMLLIBDIR)
install -c -m 0644 perl.a libperl.a $(OCAMLLIBDIR)
install -c -m 0644 dllperl.so $(OCAMLLIBDIR)/stublibs
# perl4caml configuration -*- Makefile -*-
-# $Id: Makefile.config,v 1.2 2003-10-12 12:14:06 rich Exp $
+# $Id: Makefile.config,v 1.3 2003-10-12 17:33:14 rich Exp $
# PERLINCDIR
# Directory containing the Perl include files, eg. <EXTERN.h>.
# PACKAGE and VERSION
PACKAGE := perl4caml
-VERSION := 0.2.0
+VERSION := 0.2.1
*.cma
*.cmxa
test
+loadpage
\ No newline at end of file
--- /dev/null
+(* Example program which uses LWP::UserAgent and HTML::TreeBuilder to
+ * download an HTTP page and parse it.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: loadpage.ml,v 1.1 2003-10-12 17:33:14 rich Exp $
+ *)
+
+open Printf
+
+open Pl_LWP_UserAgent
+open Pl_HTTP_Request
+open Pl_HTML_TreeBuilder
+open Pl_HTML_Element
+
+let () =
+ (* This is a hack which shouldn't be needed in future. *)
+ Perl.eval "use LWP::UserAgent";
+ Perl.eval "use Net::HTTP";
+
+ let site =
+ if Array.length Sys.argv >= 2 then
+ Sys.argv.(1)
+ else
+ "http://www.merjis.com/" in
+
+ (* Create the UserAgent object. *)
+ let ua = Pl_LWP_UserAgent.new_ ~env_proxy:true () in
+
+ (* Fetch the page. *)
+ let req = Pl_HTTP_Request.new_ "GET" ~uri:site () in
+ let res = ua#request req in
+
+ if not res#is_success then
+ failwith ("Error while fetching " ^ site ^ ": " ^ res#status_line);
+
+ (* Extract the content of the page. *)
+ let content = res#content in
+
+ (* Parse it using HTML::TreeBuilder. *)
+ let tree = Pl_HTML_TreeBuilder.new_from_content content in
+
+ (* Turn the tree into an HTML::Element. *)
+ let tree = tree#elementify in
+
+ (* Print out the resulting tree. *)
+ let rec print root =
+ let tag = root#tag in
+ let attrs = root#all_external_attr in
+ let subnodes = root#content_list in
+
+ printf "Start tag: %s\n" tag;
+ List.iter (fun (name, value) ->
+ printf "\tAttr: %s=\"%s\"\n" name value) attrs;
+
+ List.iter (fun node ->
+ match node with
+ Element node -> print node
+ | String str ->
+ printf "String: %s\n" str) subnodes;
+ printf "End tag: %s\n" tag
+ in
+ print tree;
+
+ (* Destroy the Perl interpreter. *)
+ Perl.destroy ()
(* Simple test of the API.
* Copyright (C) 2003 Merjis Ltd.
- * $Id: test.ml,v 1.1 2003-10-12 11:56:27 rich Exp $
+ * $Id: test.ml,v 1.2 2003-10-12 17:33:14 rich Exp $
*)
open Printf
let () =
- (* Arguments passed to the Perl "command line". Loads [test.pl] *)
- let args = [| ""; "-wT"; "examples/test.pl" |] in
-
- (* Create the Perl interpreter. *)
- let pl = Perl.create ~args () in
+ (* Load "test.pl". *)
+ Perl.eval "require 'examples/test.pl'";
(* Call some subroutines in [test.pl]. *)
let sv = Perl.call ~fn:"return_one" [] in
printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout;
(* Destroy the interpreter. *)
- Perl.destroy pl
+ Perl.destroy ()
(* Interface to Perl from OCaml.
* Copyright (C) 2003 Merjis Ltd.
- * $Id: perl.ml,v 1.3 2003-10-12 11:56:26 rich Exp $
+ * $Id: perl.ml,v 1.4 2003-10-12 17:33:14 rich Exp $
*)
type t
exception Perl_failure of string
-external init : unit -> unit = "perl4caml_init"
-let () =
+external c_init : unit -> unit = "perl4caml_init"
+let init () =
Callback.register_exception "perl4caml_perl_failure" (Perl_failure "");
- init () (* Initialise C code. *)
+ c_init () (* Initialise C code. *)
+
+external destroy : unit -> unit
+ = "perl4caml_destroy"
external create : ?args:string array -> unit -> t
= "perl4caml_create"
-external destroy : t -> unit
- = "perl4caml_destroy"
-
external set_context : t -> unit
= "perl4caml_set_context"
external sv_of_string : string -> sv = "perl4caml_sv_of_string"
external sv_is_true : sv -> bool = "perl4caml_sv_is_true"
external sv_is_undef : sv -> bool = "perl4caml_sv_is_undef"
-external sv_get_undef : unit -> sv = "perl4caml_sv_get_undef"
-external sv_get_yes : unit -> sv = "perl4caml_sv_get_yes"
-external sv_get_no : unit -> sv = "perl4caml_sv_get_no"
+external sv_undef : unit -> sv = "perl4caml_sv_undef"
+external sv_yes : unit -> sv = "perl4caml_sv_yes"
+external sv_no : unit -> sv = "perl4caml_sv_no"
+
+let sv_true () = sv_of_int 1
+let sv_false () = sv_of_int 0
+
+let bool_of_sv = sv_is_true
+let sv_of_bool b = if b then sv_true () else sv_false ()
+
+type sv_t = SVt_NULL
+ | SVt_IV
+ | SVt_NV
+ | SVt_PV
+ | SVt_RV
+ | SVt_PVAV
+ | SVt_PVHV
+ | SVt_PVCV
+ | SVt_PVGV
+ | SVt_PVMG
+
+external sv_type : sv -> sv_t = "perl4caml_sv_type"
-let sv_undef = sv_get_undef ()
-let sv_true = sv_get_yes ()
-let sv_false = sv_get_no ()
+external deref : sv -> sv = "perl4caml_deref"
external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv"
*
* Copyright (C) 2003 Merjis Ltd.
*
- * $Id: perl.mli,v 1.3 2003-10-12 11:56:26 rich Exp $
+ * $Id: perl.mli,v 1.4 2003-10-12 17:33:14 rich Exp $
*)
type t
exception Perl_failure of string
(** [die] in Perl code is translated automatically into this exception. *)
+val init : unit -> unit
+(** Don't call this. Instead link your program with [perl_init.cmo] or
+ * [perl_init.cmx] which calls this for you.
+ *)
+
+external destroy : unit -> unit
+ = "perl4caml_destroy"
+(** Destroy the current Perl interpreter, performing any necessary cleanup.
+ * You should call this at the end of your program, otherwise Perl won't
+ * properly clean up.
+ *
+ * Note that a Perl interpreter is created for you by default when you
+ * use perl4caml.
+ *)
+
external create : ?args:string array -> unit -> t
= "perl4caml_create"
-(** Create a Perl interpreter.
+(** Create a new Perl interpreter. (Note that a Perl interpreter is created
+ * for you by default so you don't need to call this).
*
* The optional [?args] parameter is the command line passed to the
* interpreter, and controls things like whether warnings are enabled
* Perl won't allow you to create multiple interpreters at the same time
* unless Perl itself was compiled with [-Dusemultiplicity]. However you
* can create, then destroy, then create another and so on.
+ *
+ * The newly created interpreter is set as the "current interpreter".
*)
-external destroy : t -> unit
- = "perl4caml_destroy"
-(** Destroy a Perl interpreter, performing any necessary cleanup. *)
-
external set_context : t -> unit
= "perl4caml_set_context"
(** IF Perl was compiled with [-Dusemultiplicity] and IF you are using
(** Convert a Perl [SV] into a string. *)
external sv_of_string : string -> sv = "perl4caml_sv_of_string"
(** Convert a [string] into a Perl [SV]. *)
+val bool_of_sv : sv -> bool
+(** Convert an [SV] into a boolean. *)
+val sv_of_bool : bool -> sv
+(** Convert a boolean into an [SV]. *)
+
external sv_is_true : sv -> bool = "perl4caml_sv_is_true"
(** Return [true] if the [SV] is "true" (in the Perl sense of truth). *)
external sv_is_undef : sv -> bool = "perl4caml_sv_is_undef"
(** Return [true] if the [SV] is undefined (is [undef]). *)
-val sv_undef : sv
+external sv_undef : unit -> sv = "perl4caml_sv_undef"
(** Returns [undef]. *)
-val sv_true : sv
+val sv_true : unit -> sv
(** Returns an [SV] which is true. *)
-val sv_false : sv
+val sv_false : unit -> sv
(** Returns an [SV] which is false. *)
+external sv_yes : unit -> sv = "perl4caml_sv_yes"
+(** Returns Perl's internal [PL_sv_yes]. (There are some unresolved issues
+ * with using this, so use {!sv_true} instead). *)
+external sv_no : unit -> sv = "perl4caml_sv_no"
+(** Returns Perl's internal [PL_sv_no]. (There are some unresolved issues
+ * with using this, so use {!sv_false} instead). *)
+
+(* Actually there are many more types defined than this ... *)
+type sv_t = SVt_NULL
+ | SVt_IV (** Integer scalar. *)
+ | SVt_NV (** Floating point scalar. *)
+ | SVt_PV (** String scalar. *)
+ | SVt_RV (** Reference. *)
+ | SVt_PVAV (** Array ref. *)
+ | SVt_PVHV (** Hash ref. *)
+ | SVt_PVCV (** Code ref. *)
+ | SVt_PVGV (** Glob. *)
+ | SVt_PVMG (** Blessed or magical scalar. *)
+external sv_type : sv -> sv_t = "perl4caml_sv_type"
+(** Return the type of data contained in an [SV]. Somewhat equivalent to
+ * calling Perl's [ref] function.
+ *)
+
+external deref : sv -> sv = "perl4caml_deref"
+(** The input is a reference to a scalar. This returns the underlying
+ * scalar [SV]. If the input is not a reference to a scalar, throws
+ * [Invalid_arg].
+ *)
+(*
+external deref_array : sv -> av = "perl4caml_deref_array"
+(** The input is a reference to an array. This returns the underlying
+ * array [AV]. If the input is not a reference to an array, throws
+ * [Invalid_arg].
+ *)
+external deref_hash : sv -> hv = "perl4caml_deref_hash"
+(** The input is a reference to a hash. This returns the underlying
+ * hash [HV]. If the input is not a reference to a hash, throws
+ * [Invalid_arg].
+ *)
+*)
external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv"
(** Return a scalar value by name. For example, if you have a symbol
/* Interface to Perl from OCaml.
* Copyright (C) 2003 Merjis Ltd.
- * $Id: perl_c.c,v 1.3 2003-10-12 11:56:26 rich Exp $
+ * $Id: perl_c.c,v 1.4 2003-10-12 17:33:14 rich Exp $
*/
#include <stdio.h>
CAMLprim value
perl4caml_init (value unit)
{
+ static char *argv[] = { "", "-w", "-e", "0" };
+ int argc = sizeof argv / sizeof argv[0];
+
PERL_SYS_INIT3 (NULL, NULL, NULL);
+
+ /* Create a default interpreter. */
+ my_perl = perl_alloc ();
+ perl_construct (my_perl);
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+ perl_parse (my_perl, NULL, argc, argv, NULL);
+ /*perl_run (my_perl);*/
+
return Val_unit;
}
perl_construct (my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse (my_perl, NULL, argc, argv, NULL);
- perl_run (my_perl);
+ /*perl_run (my_perl);*/
CAMLreturn (Val_perl (my_perl));
}
CAMLprim value
-perl4caml_destroy (value plv)
+perl4caml_destroy (value unit)
{
- CAMLparam1 (plv);
- PerlInterpreter *pl = Perl_val (plv);
+ CAMLparam1 (unit);
+
+ perl_destruct (my_perl);
+ perl_free (my_perl);
- perl_destruct (pl);
- perl_free (pl);
+ /* Force a segfault if someone tries to use a Perl function without
+ * creating another interpreter first.
+ */
+ my_perl = 0;
CAMLreturn (Val_unit);
}
}
CAMLprim value
-perl4caml_sv_get_undef (value unit)
+perl4caml_sv_undef (value unit)
{
CAMLparam1 (unit);
CAMLreturn (Val_sv (&PL_sv_undef));
}
CAMLprim value
-perl4caml_sv_get_yes (value unit)
+perl4caml_sv_yes (value unit)
{
CAMLparam1 (unit);
CAMLreturn (Val_sv (&PL_sv_yes));
}
CAMLprim value
-perl4caml_sv_get_no (value unit)
+perl4caml_sv_no (value unit)
{
CAMLparam1 (unit);
CAMLreturn (Val_sv (&PL_sv_no));
}
CAMLprim value
+perl4caml_sv_type (value svv)
+{
+ CAMLparam1 (svv);
+ SV *sv = Sv_val (svv);
+
+ switch (SvTYPE (sv))
+ {
+ case SVt_IV: CAMLreturn (Val_int (1));
+ case SVt_NV: CAMLreturn (Val_int (2));
+ case SVt_PV: CAMLreturn (Val_int (3));
+ case SVt_RV: CAMLreturn (Val_int (4));
+ case SVt_PVAV: CAMLreturn (Val_int (5));
+ case SVt_PVHV: CAMLreturn (Val_int (6));
+ case SVt_PVCV: CAMLreturn (Val_int (7));
+ case SVt_PVGV: CAMLreturn (Val_int (8));
+ case SVt_PVMG: CAMLreturn (Val_int (9));
+ default: CAMLreturn (Val_int (0));
+ }
+}
+
+CAMLprim value
+perl4caml_deref (value svv)
+{
+ CAMLparam1 (svv);
+ CAMLlocal1 (rsvv);
+ SV *sv = Sv_val (svv);
+
+ if (SvTYPE (sv) != SVt_RV)
+ invalid_argument ("deref: SV is not a reference");
+ switch (SvTYPE (SvRV (sv))) {
+ case SVt_IV:
+ case SVt_NV:
+ case SVt_PV:
+ case SVt_RV:
+ case SVt_PVMG:
+ break;
+ default:
+ invalid_argument ("deref: SV is not a reference to a scalar");
+ }
+ rsvv = Val_sv (SvRV (sv));
+ CAMLreturn (rsvv);
+}
+
+CAMLprim value
perl4caml_get_sv (value optcreate, value name)
{
CAMLparam2 (optcreate, name);
CAMLreturn (Val_sv (sv));
}
+static inline void
+check_perl_failure ()
+{
+ SV *errsv = get_sv ("@", TRUE);
+
+ if (SvTRUE (errsv)) /* Equivalent of $@ in Perl. */
+ {
+ CAMLlocal1 (errv);
+ STRLEN n_a;
+ const char *err = SvPV (errsv, n_a);
+
+ errv = copy_string (err);
+
+ raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
+ }
+}
+
CAMLprim value
perl4caml_call (value optsv, value optfnname, value arglist)
{
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- {
- svv = Val_sv (sv);
- CAMLreturn (svv);
- }
+ svv = Val_sv (sv);
+ CAMLreturn (svv);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
+ check_perl_failure ();
- errv = copy_string (err);
-
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- CAMLreturn (list);
+ CAMLreturn (list);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- CAMLreturn (Val_unit);
+ CAMLreturn (Val_unit);
}
CAMLprim value
SV *sv;
CAMLlocal2 (errv, svv);
- ENTER;
- SAVETMPS;
+ sv = eval_pv (String_val (expr), G_SCALAR);
- PUSHMARK (SP);
- eval_pv (String_val (expr), G_SCALAR);
+ check_perl_failure ();
- SPAGAIN;
- sv = newSVsv (POPs);
- PUTBACK;
- FREETMPS;
- LEAVE;
-
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
-
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- {
- svv = Val_sv (sv);
- CAMLreturn (svv);
- }
+ svv = Val_sv (sv);
+ CAMLreturn (svv);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- {
- svv = Val_sv (sv);
- CAMLreturn (svv);
- }
+ svv = Val_sv (sv);
+ CAMLreturn (svv);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- CAMLreturn (list);
+ CAMLreturn (list);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- CAMLreturn (Val_unit);
+ CAMLreturn (Val_unit);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- {
- svv = Val_sv (sv);
- CAMLreturn (svv);
- }
+ svv = Val_sv (sv);
+ CAMLreturn (svv);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- CAMLreturn (list);
+ CAMLreturn (list);
}
CAMLprim value
FREETMPS;
LEAVE;
- /* Died with an error?
- * XXX Actually this doesn't work for some reason.
- */
- if (SvTRUE (ERRSV))
- {
- STRLEN n_a;
- const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */
-
- errv = copy_string (err);
+ check_perl_failure ();
- raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
- }
- else
- CAMLreturn (Val_unit);
+ CAMLreturn (Val_unit);
}
static value
--- /dev/null
+(* Every program must link with perl_init.cmo (or perl_init.cmx).
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: perl_init.ml,v 1.1 2003-10-12 17:33:14 rich Exp $
+ *)
+
+Perl.init ()
--- /dev/null
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
--- /dev/null
+(* Wrapper around Perl HTML::Element class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_HTML_Element.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+type 'a content_t = Element of 'a | String of string
+
+class html_element sv =
+
+ let rec assocs_of_svlist = function
+ [] -> []
+ | [x] -> failwith "HTML::Element all_attr returned odd-length list!"
+ | svname :: svvalue :: xs ->
+ (string_of_sv svname, string_of_sv svvalue) :: assocs_of_svlist xs
+ in
+
+ let rec list_of_svlist = function
+ [] -> []
+ | sv :: xs ->
+ string_of_sv sv :: list_of_svlist xs
+ in
+
+object (self)
+
+ method sv = sv
+
+ method attr name =
+ string_of_sv (call_method sv "attr" [sv_of_string name])
+ method set_attr name value =
+ call_method_void sv "attr" [sv_of_string name; sv_of_string value]
+ method tag =
+ string_of_sv (call_method sv "tag" [])
+ method set_tag tag =
+ call_method_void sv "tag" [sv_of_string tag]
+ method parent =
+ let sv = call_method sv "parent" [] in
+ new html_element sv
+ method set_parent (parent : html_element) =
+ call_method_void sv "parent" [parent#sv]
+ method content_list =
+ let svlist = call_method_array sv "content_list" [] in
+ List.map
+ (fun c ->
+ match sv_type c with
+ SVt_PV -> String (string_of_sv c)
+ | SVt_RV -> Element (new html_element (deref c))
+ | _ -> failwith "HTML::Element content_type: unknown type"
+ ) svlist
+ method all_attr =
+ let svlist = call_method_array sv "all_attr" [] in
+ assocs_of_svlist svlist
+ method all_attr_names =
+ let svlist = call_method_array sv "all_attr_names" [] in
+ list_of_svlist svlist
+ method all_external_attr =
+ let svlist = call_method_array sv "all_external_attr" [] in
+ assocs_of_svlist svlist
+ method all_external_attr_names =
+ let svlist = call_method_array sv "all_external_attr_names" [] in
+ list_of_svlist svlist
+
+end
+
+(* Note that "new" is a reserved word, so I've appended an _ character. *)
+let new_ tag attrs =
+ let rec loop = function
+ [] -> []
+ | (name, value) :: xs -> sv_of_string name :: sv_of_string value :: loop xs
+ in
+ let sv = call_class_method "HTML::Element" "new"
+ (sv_of_string tag :: loop attrs) in
+ new html_element sv
--- /dev/null
+(* Wrapper around Perl HTML::Parser class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_HTML_Parser.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+class html_parser sv =
+
+object (self)
+
+ method parse_file filename =
+ call_method_void sv "parse_file" [sv_of_string filename]
+ method parse content =
+ call_method_void sv "parse" [sv_of_string content]
+ method eof =
+ call_method_void sv "eof" []
+ method delete =
+ call_method_void sv "delete" []
+
+end
--- /dev/null
+(* Wrapper around Perl HTML::TreeBuilder class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_HTML_TreeBuilder.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+open Pl_HTML_Parser
+open Pl_HTML_Element
+
+class html_treebuilder sv =
+
+object (self)
+ inherit html_parser sv
+
+ method elementify =
+ let sv = call_method sv "elementify" [] in
+ new html_element sv
+end
+
+(* Note that "new" is a reserved word, so I've appended an _ character. *)
+let new_ () =
+ let sv = call_class_method "HTML::TreeBuilder" "new" [] in
+ new html_treebuilder sv
+
+let new_from_file filename =
+ let sv = call_class_method "HTML::TreeBuilder" "new_from_file"
+ [sv_of_string filename] in
+ new html_treebuilder sv
+
+let new_from_content content =
+ let sv = call_class_method "HTML::TreeBuilder" "new_from_content"
+ [sv_of_string content] in
+ new html_treebuilder sv
--- /dev/null
+(* Wrapper around Perl HTTP::Message class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_HTTP_Message.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+class http_message sv =
+
+object (self)
+
+ method content =
+ string_of_sv (call_method sv "content" [])
+ method set_content content =
+ call_method_void sv "set_content" [sv_of_string content]
+
+end
--- /dev/null
+(* Wrapper around Perl HTTP::Request class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_HTTP_Request.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+open Pl_HTTP_Message
+open Pl_URI
+
+class http_request sv =
+
+object (self)
+ inherit http_message sv
+
+ method sv = sv
+
+ method method_ =
+ string_of_sv (call_method sv "method" [])
+ method set_method meth =
+ call_method_void sv "method" [sv_of_string meth]
+ method as_string =
+ string_of_sv (call_method sv "as_string" [])
+
+end
+
+let new_ meth ?uri_obj ?uri (* ?header ?content *) () =
+ let sv =
+ match uri_obj, uri with
+ None, None ->
+ failwith ("Pl_HTTP_Request.new_ must be called with either a "^
+ "~uri_obj (URI object) or ~uri (string) parameter.")
+ | Some (uri_obj : uri), None ->
+ call_class_method "HTTP::Request" "new" [sv_of_string meth;
+ uri_obj#sv]
+ | _, Some uri ->
+ call_class_method "HTTP::Request" "new" [sv_of_string meth;
+ sv_of_string uri]
+ in
+ new http_request sv
--- /dev/null
+(* Wrapper around Perl HTTP::Response class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_HTTP_Response.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+open Pl_HTTP_Message
+
+class http_response sv =
+
+object (self)
+ inherit http_message sv
+
+ method code =
+ string_of_sv (call_method sv "code" [])
+ method set_code code =
+ call_method_void sv "code" [sv_of_string code]
+ method message =
+ string_of_sv (call_method sv "message" [])
+ method set_message message =
+ call_method_void sv "message" [sv_of_string message]
+ method status_line =
+ string_of_sv (call_method sv "status_line" [])
+ method base =
+ string_of_sv (call_method sv "base" [])
+ method as_string =
+ string_of_sv (call_method sv "as_string" [])
+ method is_info =
+ bool_of_sv (call_method sv "is_info" [])
+ method is_success =
+ bool_of_sv (call_method sv "is_success" [])
+ method is_redirect =
+ bool_of_sv (call_method sv "is_redirect" [])
+ method is_error =
+ bool_of_sv (call_method sv "is_error" [])
+ method error_as_HTML =
+ string_of_sv (call_method sv "error_as_HTML" [])
+
+end
+
+(* let new_ ... *)
--- /dev/null
+(* Wrapper around Perl LWP::UserAgent class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_LWP_UserAgent.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+open Pl_HTTP_Request
+open Pl_HTTP_Response
+
+class lwp_useragent sv =
+
+object (self)
+
+ method simple_request (request : http_request) =
+ let sv = call_method sv "simple_request" [request#sv] in
+ new http_response sv
+ method request (request : http_request) =
+ let sv = call_method sv "simple_request" [request#sv] in
+ new http_response sv
+ method agent =
+ string_of_sv (call_method sv "agent" [])
+ method set_agent v =
+ call_method_void sv "agent" [sv_of_string v]
+ method from =
+ string_of_sv (call_method sv "from" [])
+ method set_from v =
+ call_method_void sv "from" [sv_of_string v]
+ method timeout =
+ int_of_sv (call_method sv "timeout" [])
+ method set_timeout v =
+ call_method_void sv "timeout" [sv_of_int v]
+ method parse_head =
+ bool_of_sv (call_method sv "parse_head" [])
+ method set_parse_head v =
+ call_method_void sv "parse_head" [sv_of_bool v]
+ method max_size =
+ int_of_sv (call_method sv "max_size" [])
+ method set_max_size v =
+ call_method_void sv "max_size" [sv_of_int v]
+ method env_proxy =
+ call_method_void sv "env_proxy" []
+
+end
+
+(* Note that "new" is a reserved word, so I've appended an _ character. *)
+let new_ ?agent ?from ?timeout ?use_eval ?parse_head ?max_size
+ ?env_proxy ?keep_alive () =
+ let args = ref [] in
+ let may f = function None -> () | Some v -> f v in
+ may (fun v ->
+ args := sv_of_string "agent" :: sv_of_string v :: !args) agent;
+ may (fun v ->
+ args := sv_of_string "from" :: sv_of_string v :: !args) from;
+ may (fun v ->
+ args := sv_of_string "timeout" :: sv_of_int v :: !args) timeout;
+ may (fun v ->
+ args := sv_of_string "use_eval" :: sv_of_bool v :: !args) use_eval;
+ may (fun v ->
+ args := sv_of_string "parse_head" :: sv_of_bool v :: !args)parse_head;
+ may (fun v ->
+ args := sv_of_string "max_size" :: sv_of_int v :: !args) max_size;
+ may (fun v ->
+ args := sv_of_string "env_proxy" :: sv_of_bool v :: !args) env_proxy;
+ may (fun v ->
+ args := sv_of_string "keep_alive" :: sv_of_int v :: !args) keep_alive;
+ let sv = call_class_method "LWP::UserAgent" "new" !args in
+ new lwp_useragent sv
--- /dev/null
+(* Wrapper around Perl URI class.
+ * Copyright (C) 2003 Merjis Ltd.
+ * $Id: pl_URI.ml,v 1.1 2003-10-12 17:33:15 rich Exp $
+ *)
+
+open Perl
+
+class uri sv =
+
+object (self)
+
+ method sv = sv
+
+ method scheme =
+ string_of_sv (call_method sv "scheme" [])
+ method set_scheme scheme =
+ call_method_void sv "scheme" [sv_of_string scheme]
+ method opaque =
+ string_of_sv (call_method sv "opaque" [])
+ method set_opaque opaque =
+ call_method_void sv "opaque" [sv_of_string opaque]
+ method path =
+ string_of_sv (call_method sv "path" [])
+ method set_path path =
+ call_method_void sv "path" [sv_of_string path]
+ method fragment =
+ string_of_sv (call_method sv "fragment" [])
+ method set_fragment fragment =
+ call_method_void sv "fragment" [sv_of_string fragment]
+ method as_string =
+ string_of_sv (call_method sv "as_string" [])
+ method canonical =
+ string_of_sv (call_method sv "canonical" [])
+ method abs base =
+ string_of_sv (call_method sv "abs" [sv_of_string base])
+ method rel base =
+ string_of_sv (call_method sv "rel" [sv_of_string base])
+
+end
+
+let new_ ?scheme str =
+ let args =
+ [sv_of_string str] @
+ match scheme with
+ None -> []
+ | Some scheme -> [sv_of_string scheme] in
+ let sv = call_class_method "URI" "new" args in
+ new uri sv
git.annexia.org / perl4caml.git / commitdiff