Writing a high-level wrapper around a Perl library
This document discusses the theory and practice behind writing
a wrapper around a typical object-oriented Perl library. We
use Pl_LWP_UserAgent
as an example. (This is the high-level wrapper around the
LWP::UserAgent
library).
Don't worry - writing wrappers is really not very hard at all. I
hope that you, the reader, will write some wrappers around your
favorite Perl libraries and contribute them back to
perl4caml
development.
First steps
I'm going to use LWP::UserAgent
as my example throughout this document. Substitute that for whatever
library you want to wrap up and call from OCaml.
First of all make sure you have the library installed and working
under Perl, and make sure you have the manual page for that
library in front of you:
The low-level Perl module offers
two useful functions and a useful datatype which we'll be using
extensively. The useful functions are:
Function name
Perl equivalent
Description
call_class_method
$obj = LWP::UserAgent->new (args...)
Calls a static method or constructor on a class.
call_method
$obj->some_method (args...)
Calls an instance method on an object.
The useful datatype is called the Perl.sv (an
abstract type), which represents a scalar value in Perl (anything
you would normally write in Perl with a $, including
numbers, strings, references and blessed objects). To find out
more about "SVs" see the perlguts(3) man page.
To see how these three things interact, let's create an
LWP::UserAgent object and call a method on it:
# #load "perl4caml.cma";;
# open Perl;;
# let sv = call_class_method "LWP::UserAgent" "new" [];;
val sv : Perl.sv = <abstr>
# let agent = call_method sv "agent" [];;
val agent : Perl.sv = <abstr>
# string_of_sv agent;;
- : string = "libwww-perl/5.69"
Note how the variable sv contains the actual Perl
object (an instance of LWP::UserAgent). To be
quite clear, this is the equivalent of the following Perl code:
You could actually just continue to use the low-level interface
to access Perl objects directly, but there are three problems with
this: firstly it's cumbersome because you have to continually
convert to and from SVs; secondly it's not type safe
(eg. calling string_of_sv might fail if the SV
isn't actually a string); thirdly there are more pleasant ways
to present this interface.
Writing a high-level wrapper around these low-level operations
is what is described in the rest of this document ...
Classes and constructors
Our general plan, therefore, will be to create an OCaml class
corresponding to LWP::UserAgent, which hides the
implementation (the sv, the calls to
call_method, and the conversion of arguments
to and from SVs). We will also need to write one or more constructor
function.
We will write at least one method for every method exported by
the Perl interface. Sometimes we'll write two methods for each
Perl method, as in the case where a Perl method is a "getter/setter":
$ua->agent([$product_id])
Get/set the product token that is used to identify the user agent
on the network. The agent value is sent as the "User-Agent" header
in the requests.
becomes two methods in the OCaml version:
class lwp_useragent sv = object (self)
(* ... *)
method agent : string
method set_agent : string -> unit
end
We will also write at least one function for every
constructor or static function exported from Perl.
The OCaml object itself contains the sv which
corresponds to the Perl SV (ie. the actual Perl object).
Here is the shape of our class:
(** Wrapper around Perl [LWP::UserAgent] class.
*
* Copyright (C) 20xx your_organisation
*
* $ Id $
*)
open Perl
let _ = eval "use LWP::UserAgent"
class lwp_useragent sv = object (self)
The methods will go here ...
end
(* The "new" constructor. Note that "new" is a reserved word in OCaml. *)
let new_ ... =
...
let sv = call_class_method "LWP::UserAgent" "new" [args ...] in
new lwp_useragent sv
Any other static functions will go here ...
Notice a few things here:
There is some ocamldoc describing the class.
We "open Perl" to avoid having to prefix everything with
Perl..
We eval "use LWP::UserAgent" when the module
is loaded. This is required by Perl.
The sv (scalar value representing the actual
object) is passed as a parameter to the class.
Writing methods
Getters and setters
Of all types of methods, getters and setters are the easiest
to write. First of all, check the manual page to find out what
type the slot is. You'll need to write one get method and
one set method. (Rarely you'll find getters and setters which
are quasi-polymorphic, for instance they can take a string or
an arrayref. You'll need to think more deeply about these,
because they require one set method for each type, and the
get method can be complicated).
Here's our getter and setter for the agent slot, described above.
The agent is a string:
The get method is just called agent (not
"get_agent"). This is the standard for OCaml code.
We use string_of_sv and sv_of_string
to convert to and from SVs. This will ensure that the
class interface will have the correct type (string), and
thus be type safe as far as the calling code is concerned,
and also means the caller doesn't need to worry about
SVs.
The set method called call_method_void which
we haven't seen before. This is exactly the same as
call_method except that the method is called
in a "void context" - in other words, any return value is
thrown away. This is slightly more efficient than ignoring
the return value.
Other methods are perhaps simpler to wrap than getters and
setters. LWP::UserAgent contains an interesting
method called request (which actually runs the
request).
What's particularly interesting about this method are the
parameter and return value. It takes an HTTP::Request
object and returns an HTTP::Response.
I have already wrapped HTTP::Request and
HTTP::Response as modules
Pl_HTTP_Request and
Pl_HTTP_Response
respectively. You should go and look at the code in those
modules now.
If request requires a parameter, what should that
parameter be? Naturally it should be the SV corresponding to
the HTTP::Request object. To get this, I provided
an #sv method on the http_request class.
And what will request return? Naturally it will
return an SV which corresponds to the (newly created inside
Perl) HTTP::Response object. We need to wrap
this up and create a new OCaml http_response object,
containing that SV.
This is what the final method looks like:
method request (request : http_request) =
let sv = call_method sv "request" [request#sv] in
new http_response sv
It's actually not so complicated.
Writing constructors and static functions
Constructors are fairly simple, although the new_
function inside Pl_LWP_UserAgent is complicated
by the many optional arguments which LWP::UserAgent->new
can take.
Here is the guts, omitting all but one of the optional args:
let new_ ?agent (* ... *) () =
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;
(* ... *)
let sv = call_class_method "LWP::UserAgent" "new" !args in
new lwp_useragent sv
It works simply enough, first building up a list of svs
corresponding to the arguments, then calling
call_class_method to create the Perl object, then
returning a constructed OCaml lwp_useragent object
containing that sv.
Contributing wrappers back to perl4caml
If you write a wrapper for a Perl class, particularly one from
CPAN, I urge you to
contribute it back to the perl4caml
development effort. Your contribution enriches the project
as a whole, and makes OCaml more useful too.
Richard W.M. Jones
Last modified: Thu Oct 16 14:39:02 BST 2003
perl4caml-0.9.5/.cvsignore 0000644 0000764 0000764 00000000127 10330373424 015001 0 ustar rjones rjones *.cmi
*.cmo
*.cmx
*.cma
*.cmxa
perl4caml-*.tar.gz
html
META
configure-stamp
build-stamp perl4caml-0.9.5/perl.mli 0000644 0000764 0000764 00000026370 10762251735 014467 0 ustar rjones rjones (** Interface to Perl from OCaml. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: perl.mli,v 1.16 2008-03-01 13:02:21 rich Exp $
*)
type sv
(** Perl scalar value. *)
type av
(** Perl array value. *)
type hv
(** Perl hash value. *)
exception Perl_failure of string
(** [die] in Perl code is translated automatically into this exception. *)
val int_of_sv : sv -> int
(** Convert a Perl [SV] into an integer. Note that OCaml [int]s aren't
* large enough to store the full 32 (or 64) bits from a Perl integer,
* so you may get a silent overflow.
*)
val sv_of_int : int -> sv
(** Convert an [int] into a Perl [SV]. *)
val float_of_sv : sv -> float
(** Convert a Perl [SV] into a float. *)
val sv_of_float : float -> sv
(** Convert a [float] into a Perl [SV]. *)
val string_of_sv : sv -> string
(** Convert a Perl [SV] into a string. *)
val sv_of_string : string -> sv
(** 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]. *)
val sv_is_true : sv -> bool
(** Return [true] if the [SV] is "true" (in the Perl sense of truth). *)
val sv_is_undef : sv -> bool
(** Return [true] if the [SV] is undefined (is [undef]). *)
val sv_undef : unit -> sv
(** Returns [undef]. *)
val sv_true : unit -> sv
(** Returns an [SV] which is true. *)
val sv_false : unit -> sv
(** Returns an [SV] which is false. *)
val sv_yes : unit -> sv
(** Returns Perl's internal [PL_sv_yes]. (There are some unresolved issues
* with using this, so use {!Perl.sv_true} instead). *)
val sv_no : unit -> sv
(** Returns Perl's internal [PL_sv_no]. (There are some unresolved issues
* with using this, so use {!Perl.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. *)
| SVt_PVHV (** Hash. *)
| SVt_PVCV (** Code. *)
| SVt_PVGV (** Glob (possibly a file handle). *)
| SVt_PVMG (** Blessed or magical scalar. *)
val sv_type : sv -> sv_t
(** Return the type of data contained in an [SV]. Somewhat equivalent to
* calling Perl's [ref] function.
*)
val string_of_sv_t : sv_t -> string
(** Return a printable string for an [sv_t] ([SV] type). *)
val reftype : sv -> sv_t
(** The parameter [sv] must be a reference. This convenience function
* works out what it is a reference to, either a scalar, array, hash,
* code or glob. If the parameter is not a reference, or is a reference
* to an unknown type, then this will throw [Invalid_argument]. *)
val address_of_sv : sv -> Nativeint.t
(** Returns the address of the SV. Useful for debugging since
* Perl also prints out addresses on internal errors.
*)
val address_of_av : av -> Nativeint.t
(** Returns the address of the AV. Useful for debugging since
* Perl also prints out addresses on internal errors.
*)
val address_of_hv : hv -> Nativeint.t
(** Returns the address of the HV. Useful for debugging since
* Perl also prints out addresses on internal errors.
*)
val scalarref : sv -> sv
(** Given a scalar, this returns a reference to the scalar. Note that
* because references are [SV]s, this returns [sv].
*)
val arrayref : av -> sv
(** Given an array, this returns a reference to the array. Note that
* because references are [SV]s, this returns [sv].
*)
val hashref : hv -> sv
(** Given a hash, this returns a reference to the hash. Note that
* because references are [SV]s, this returns [sv].
*)
val deref : sv -> sv
(** 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_argument].
*)
val deref_array : sv -> av
(** 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_argument].
*)
val deref_hash : sv -> hv
(** 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_argument].
*)
val av_empty : unit -> av
(** Create an empty [AV] (array). *)
val av_of_sv_list : sv list -> av
(** Create an array from a list of [SVs]. *)
val av_push : av -> sv -> unit
(** Append the [SV] to the end of the array. Same as Perl
* [push \@av, $sv]. *)
val av_pop : av -> sv
(** Remove the [SV] at the end of the array and return it. Same as
* Perl [$sv = pop \@av]. *)
val av_shift : av -> sv
(** Remove the [SV] at the beginning of the array and return it. Same as
* Perl [$sv = shift \@av]. *)
val av_unshift : av -> sv -> unit
(** Prepend the [SV] to the start of the array. Same as Perl
* [unshift \@av, $sv]. *)
val av_length : av -> int
(** Return the length of the [AV]. *)
val av_set : av -> int -> sv -> unit
(** Replace the i'th element of the [AV] with [SV]. *)
val av_get : av -> int -> sv
(** Get the i'th element of the [AV]. *)
val av_clear : av -> unit
(** Remove all elements from the [AV]. Same as Perl [\@av = ()]. *)
val av_undef : av -> unit
(** Delete the [AV] (and all elements in it). Same as Perl [undef \@av]. *)
val av_extend : av -> int -> unit
(** Extend the [AV] so it contains at least [n+1] elements. Note that
* this apparently just changes the amount of allocated storage. The
* extra elements are not visible until you store something in them.
*)
val av_map : (sv -> 'a) -> av -> 'a list
(** Map a function over the elements in the [AV], return a list of the
* results. *)
val list_of_av : av -> sv list
(** Convert an [AV] into a simple list of [SV]s. *)
val av_of_string_list : string list -> av
(** Build an [AV] from a list of strings. *)
val hv_empty : unit -> hv
(** Create an empty [HV] (hash). *)
val hv_set : hv -> string -> sv -> unit
(** Store the given [SV] in the named key in the hash. *)
val hv_get : hv -> string -> sv
(** Return the [SV] at the key in the hash. Throws [Not_found] if no key. *)
val hv_exists : hv -> string -> bool
(** Return true if the hash contains the given key. Same as Perl [exists]. *)
val hv_delete : hv -> string -> unit
(** Delete the given key from the hash. Same as Perl [delete]. *)
val hv_clear : hv -> unit
(** Remove all elements from the [HV]. Same as Perl [%av = ()]. *)
val hv_undef : hv -> unit
(** Delete the [HV] (and all elements in it). Same as Perl [undef %hv]. *)
val hv_of_assoc : (string * sv) list -> hv
(** Create an [HV] directly from an assoc list. Perl hashes cannot
* support multiple values attached to the same key, so if you try
* to provide an assoc list with multiple identical keys, the results
* will be undefined.
*)
val assoc_of_hv : hv -> (string * sv) list
(** Take an [HV] and return an assoc list. *)
val hv_keys : hv -> string list
(** Return all the keys of an [HV]. *)
val hv_values : hv -> sv list
(** Return all the values of an [HV]. *)
(* The following are the low-level iteration interface to hashes,
* which you probably shouldn't use directly. Use {!hv_keys},
* {!assoc_of_hv}, etc. instead. See [perlguts(3)] if you really
* want to use this interface.
*)
type he
val hv_iterinit : hv -> Int32.t
val hv_iternext : hv -> he
val hv_iterkey : he -> string
val hv_iterval : hv -> he -> sv
val hv_iternextsv : hv -> string * sv
val get_sv : ?create:bool -> string -> sv
(** Return a scalar value by name. For example, if you have a symbol
* called [$a] in Perl, then [get_sv "a"] will return its value.
*
* If the symbol does not exist, this throws [Not_found].
*
* If the optional [?create] argument is set to true and the symbol does
* not exist, then Perl will create the symbol (with value [undef]) and
* this function will return the [SV] for [undef].
*)
val get_av : ?create:bool -> string -> av
(** Same as {!Perl.get_sv} except will return and/or create [\@a]. *)
val get_hv : ?create:bool -> string -> hv
(** Same as {!Perl.get_sv} except will return and/or create [%a]. *)
val call : ?sv:sv -> ?fn:string -> sv list -> sv
(** Call a Perl function in a scalar context, either by name (using the [?fn]
* parameter) or by calling a string/CODEREF (using the [?sv] parameter).
*
* Returns the Perl [SV] containing the result value. (See
* {!Perl.int_of_sv} etc.).
*
* If the Perl code calls [die] then this will throw [Perl_failure].
*)
val call_array : ?sv:sv -> ?fn:string -> sv list -> sv list
(** Call a Perl function in an array context, either by name (using the [?fn]
* parameter) or by calling a string/CODEREF (using the [?sv] parameter).
*
* Returns the list of results.
*
* If the Perl code calls [die] then this will throw [Perl_failure].
*)
val call_void : ?sv:sv -> ?fn:string -> sv list -> unit
(** Call a Perl function in a void context, either by name (using the [?fn]
* parameter) or by calling a string/CODEREF (using the [?sv] parameter).
*
* Any results are discarded.
*
* If the Perl code calls [die] then this will throw [Perl_failure].
*)
val eval : string -> sv
(** This is exactly like the Perl [eval] command. It evaluates a piece of
* Perl code (in scalar context) and returns the result (a Perl [SV]).
*)
val call_method : sv -> string -> sv list -> sv
(** [call_method obj name [parameters]] calls the method [name] on the Perl
* object [obj] with the given parameters, in a scalar context. Thus this
* is equivalent to [$obj->name (parameters)].
*
* Returns the Perl [SV] containing the result value.
*
* If the method calls [die] then this will throw [Perl_failure].
*)
val call_method_array : sv -> string -> sv list -> sv list
(** Like [call_method], but the method is called in an array context. *)
val call_method_void : sv -> string -> sv list -> unit
(** Like [call_method], but the method is called in a void context (results
* are discarded). *)
val call_class_method : string -> string -> sv list -> sv
(** [call_class_method classname name [parameters]] calls the static method
* [name] in the Perl class [classname] with the given parameters, in a
* scalar context. Thus this is equivalent to [$classname->name (parameters)].
*
* Returns the Perl [SV] containing the result value.
*
* If the static method calls [die] then this will throw [Perl_failure].
*)
val call_class_method_array : string -> string -> sv list -> sv list
(** Like [call_class_method], but the method is called in an array context. *)
val call_class_method_void : string -> string -> sv list -> unit
(** Like [call_class_method], but the method is called in a void context. *)
perl4caml-0.9.5/META.in 0000644 0000764 0000764 00000000212 10330373424 014052 0 ustar rjones rjones name="@PACKAGE@"
version="@VERSION@"
description="Perl bindings for OCaml"
archive(byte)="perl4caml.cma"
archive(native)="perl4caml.cmxa"
perl4caml-0.9.5/COPYING.LIB 0000644 0000764 0000764 00000063445 10330373424 014455 0 ustar rjones rjones This library is distributed under the terms of the GNU LGPL with the
OCaml linking exception.
----------------------------------------------------------------------
As a special exception to the GNU Library General Public License, you
may link, statically or dynamically, a "work that uses the Library"
with a publicly distributed version of the Library to produce an
executable file containing portions of the Library, and distribute
that executable file under terms of your choice, without any of the
additional requirements listed in clause 6 of the GNU Library General
Public License. By "a publicly distributed version of the Library",
we mean either the unmodified Library as distributed by INRIA, or a
modified version of the Library that is distributed under the
conditions defined in clause 3 of the GNU Library General Public
License. This exception does not however invalidate any other reasons
why the executable file might be covered by the GNU Library General
Public License.
----------------------------------------------------------------------
GNU LIBRARY GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1991 Free Software Foundation, Inc.
59 Temple Place - Suite 330
Boston, MA 02111-1307, USA.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
[This is the first released version of the library GPL. It is
numbered 2 because it goes with version 2 of the ordinary GPL.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Library General Public License, applies to some
specially designated Free Software Foundation software, and to any
other libraries whose authors decide to use it. You can use it for
your libraries, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if
you distribute copies of the library, or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link a program with the library, you must provide
complete object files to the recipients so that they can relink them
with the library, after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
Our method of protecting your rights has two steps: (1) copyright
the library, and (2) offer you this license which gives you legal
permission to copy, distribute and/or modify the library.
Also, for each distributor's protection, we want to make certain
that everyone understands that there is no warranty for this free
library. If the library is modified by someone else and passed on, we
want its recipients to know that what they have is not the original
version, so that any problems introduced by others will not reflect on
the original authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that companies distributing free
software will individually obtain patent licenses, thus in effect
transforming the program into proprietary software. To prevent this,
we have made it clear that any patent must be licensed for everyone's
free use or not licensed at all.
Most GNU software, including some libraries, is covered by the ordinary
GNU General Public License, which was designed for utility programs. This
license, the GNU Library General Public License, applies to certain
designated libraries. This license is quite different from the ordinary
one; be sure to read it in full, and don't assume that anything in it is
the same as in the ordinary license.
The reason we have a separate public license for some libraries is that
they blur the distinction we usually make between modifying or adding to a
program and simply using it. Linking a program with a library, without
changing the library, is in some sense simply using the library, and is
analogous to running a utility program or application program. However, in
a textual and legal sense, the linked executable is a combined work, a
derivative of the original library, and the ordinary General Public License
treats it as such.
Because of this blurred distinction, using the ordinary General
Public License for libraries did not effectively promote software
sharing, because most developers did not use the libraries. We
concluded that weaker conditions might promote sharing better.
However, unrestricted linking of non-free programs would deprive the
users of those programs of all benefit from the free status of the
libraries themselves. This Library General Public License is intended to
permit developers of non-free programs to use free libraries, while
preserving your freedom as a user of such programs to change the free
libraries that are incorporated in them. (We have not seen how to achieve
this as regards changes in header files, but we have achieved it as regards
changes in the actual functions of the Library.) The hope is that this
will lead to faster development of free libraries.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, while the latter only
works together with the library.
Note that it is possible for a library to be covered by the ordinary
General Public License rather than by this special one.
GNU LIBRARY GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library which
contains a notice placed by the copyright holder or other authorized
party saying it may be distributed under the terms of this Library
General Public License (also called "this License"). Each licensee is
addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.
You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.
2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.
If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also compile or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Accompany the work with a written offer, valid for at
least three years, to give the same user the materials
specified in Subsection 6a, above, for a charge no more
than the cost of performing this distribution.
c) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
d) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. However, as a special exception,
the source code distributed need not include anything that is normally
distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License. However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.
9. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.
If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded. In such case, this License incorporates the limitation as if
written in the body of this License.
13. The Free Software Foundation may publish revised and/or new
versions of the Library General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.
Each version is given a distinguishing version number. If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation. If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission. For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this. Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.
NO WARRANTY
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.
END OF TERMS AND CONDITIONS
Appendix: How to Apply These Terms to Your New Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).
To apply these terms, attach the following notices to the library. It is
safest to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least the
"copyright" line and a pointer to where the full notice is found.
Copyright (C)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
Also add information on how to contact you by electronic and paper mail.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the library, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!
perl4caml-0.9.5/MANIFEST 0000644 0000764 0000764 00000002167 10330373424 014140 0 ustar rjones rjones .cvsignore
.depend
AUTHORS
COPYING.LIB
Makefile
Makefile.config
MANIFEST
META.in
README
doc/writing-a-wrapper.html
examples/.cvsignore
examples/google.ml
examples/loadpage.ml
examples/parsedate.ml
examples/TestClass.pm
examples/test.ml
examples/test.pl
perl.ml
perl.mli
perl_c.c
test/.cvsignore
test/001-start.ml
test/010-load.ml
test/020-eval.ml
test/030-call-method.ml
test/030-call.ml
test/100-sv.ml
test/110-av.ml
test/120-hv.ml
test/130-hv-iter.ml
test/140-ref.ml
wrappers/.cvsignore
wrappers/pl_Data_Dumper.ml
wrappers/pl_Date_Calc.ml
wrappers/pl_Date_Format.ml
wrappers/pl_Date_Parse.ml
wrappers/pl_HTML_Element.ml
wrappers/pl_HTML_Form.ml
wrappers/pl_HTML_Parser.ml
wrappers/pl_HTML_TreeBuilder.ml
wrappers/pl_HTTP_Cookies.ml
wrappers/pl_HTTP_Headers.ml
wrappers/pl_HTTP_Message.ml
wrappers/pl_HTTP_Request.ml
wrappers/pl_HTTP_Request_Common.ml
wrappers/pl_HTTP_Response.ml
wrappers/pl_LWP_UserAgent.ml
wrappers/pl_Net_Google.ml
wrappers/pl_Net_Google_Cache.ml
wrappers/pl_Net_Google_Response.ml
wrappers/pl_Net_Google_Search.ml
wrappers/pl_Net_Google_Spelling.ml
wrappers/pl_Template.ml
wrappers/pl_URI.ml
wrappers/pl_WWW_Mechanize.ml perl4caml-0.9.5/test/ 0000775 0000764 0000764 00000000000 10762251536 013772 5 ustar rjones rjones perl4caml-0.9.5/test/.cvsignore 0000644 0000764 0000764 00000000035 10330373423 015755 0 ustar rjones rjones *.bc
*.opt
*.cmi
*.cmo
*.cmx
perl4caml-0.9.5/test/130-hv-iter.ml 0000644 0000764 0000764 00000001770 10330373423 016175 0 ustar rjones rjones (* Thoroughly test HV iteration functions.
* $Id: 130-hv-iter.ml,v 1.1 2005/01/29 12:22:50 rich Exp $
*)
open Perl
let () =
let xs = [ "foo", sv_of_int 1;
"bar", sv_of_int 2;
"baz", sv_of_int 3;
"a", sv_of_int 4 ] in
let hv = hv_of_assoc xs in
assert (1 = int_of_sv (hv_get hv "foo"));
assert (2 = int_of_sv (hv_get hv "bar"));
assert (3 = int_of_sv (hv_get hv "baz"));
assert (4 = int_of_sv (hv_get hv "a"));
assert (not (hv_exists hv "b"));
assert (not (hv_exists hv "c"));
let keys = List.sort compare (hv_keys hv) in
assert (4 = List.length keys);
assert (["a"; "bar"; "baz"; "foo"] = keys);
let values = List.sort compare (List.map int_of_sv (hv_values hv)) in
assert (4 = List.length values);
assert ([1; 2; 3; 4] = values);
let xs = assoc_of_hv hv in
let xs = List.map (fun (k, sv) -> k, int_of_sv sv) xs in
let xs = List.sort compare xs in
assert (4 = List.length xs);
assert ([ "a", 4; "bar", 2; "baz", 3; "foo", 1 ] = xs)
;;
Gc.full_major ()
perl4caml-0.9.5/test/030-call.ml 0000644 0000764 0000764 00000000365 10330373423 015530 0 ustar rjones rjones (* Basic subroutine call.
* $Id: 030-call.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
let () =
ignore (eval "sub test { 42 + $_[0] }");
let sv = call ~fn:"test" [sv_of_int 10] in
assert (52 = int_of_sv sv);;
Gc.full_major ()
perl4caml-0.9.5/test/001-start.ml 0000644 0000764 0000764 00000000170 10330373423 015742 0 ustar rjones rjones (* Does nothing - just check the test harness is working.
* $Id: 001-start.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
perl4caml-0.9.5/test/010-load.ml 0000644 0000764 0000764 00000000437 10330373423 015532 0 ustar rjones rjones (* Load Perl interpreter.
* $Id: 010-load.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
(* The next line does nothing. It just forces OCaml to actually
* reference and hence load the Perl module.
*)
let _ = Perl.int_of_sv;;
(* Check for memory errors. *)
Gc.full_major ()
perl4caml-0.9.5/test/030-call-method.ml 0000644 0000764 0000764 00000000520 10330373423 016777 0 ustar rjones rjones (* Basic constructor and method calls.
* $Id: 030-call-method.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
let () =
ignore (eval "use IO::File");
let io = call_class_method "IO::File" "new_tmpfile" [] in
call_method_void io "print" [ sv_of_string "hello, world" ];
call_method_void io "close" [];;
Gc.full_major ()
perl4caml-0.9.5/test/140-ref.ml 0000644 0000764 0000764 00000001440 10330373423 015366 0 ustar rjones rjones (* Reference, dereference.
* $Id: 140-ref.ml,v 1.2 2005/04/14 13:05:12 rich Exp $
*)
open Perl
let () =
let sv = sv_of_int 42 in
let sv = scalarref sv in
assert (sv_type sv = SVt_RV);
assert (reftype sv = SVt_IV);
let sv = deref sv in
assert (42 = int_of_sv sv);
let av = av_of_string_list [ "foo"; "bar" ] in
let sv = arrayref av in
assert (sv_type sv = SVt_RV);
assert (reftype sv = SVt_PVAV);
let av = deref_array sv in
assert (2 = av_length av);
let hv = hv_empty () in
hv_set hv "foo" (sv_of_int 1);
hv_set hv "bar" (sv_of_int 2);
let sv = hashref hv in
assert (sv_type sv = SVt_RV);
assert (reftype sv = SVt_PVHV);
let hv = deref_hash sv in
assert (1 = int_of_sv (hv_get hv "foo"));
assert (2 = int_of_sv (hv_get hv "bar"));
;;
Gc.full_major ()
perl4caml-0.9.5/test/110-av.ml 0000644 0000764 0000764 00000002201 10330373423 015211 0 ustar rjones rjones (* Thoroughly test AV-related functions.
* $Id: 110-av.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
let () =
let av = av_empty () in
assert ([] = list_of_av av);
av_push av (sv_of_int 42);
av_push av (sv_of_int 84);
av_unshift av (sv_of_int 21);
av_set av 0 (sv_of_int 11);
assert (3 = av_length av);
assert (84 = int_of_sv (av_pop av));
assert (2 = av_length av);
assert (11 = int_of_sv (av_shift av));
assert (1 = av_length av);
assert (42 = int_of_sv (av_pop av));
av_extend av 3;
av_set av 0 (sv_of_int 11);
av_set av 1 (sv_of_int 22);
av_set av 2 (sv_of_int 33);
av_set av 3 (sv_of_int 44);
assert (4 = av_length av);
assert (33 = int_of_sv (av_get av 2));
assert (22 = int_of_sv (av_get av 1));
assert (44 = int_of_sv (av_pop av));
assert (3 = av_length av);
assert (33 = int_of_sv (av_pop av));
assert (11 = int_of_sv (av_shift av));
assert (22 = int_of_sv (av_pop av));
assert ([] = list_of_av av);
ignore (eval "@a = ( 'foo', 'bar' )");
let av = get_av "a" in
assert ("foo" = string_of_sv (av_get av 0));
assert ("bar" = string_of_sv (av_get av 1));
;;
Gc.full_major ()
perl4caml-0.9.5/test/100-sv.ml 0000644 0000764 0000764 00000002134 10330373423 015237 0 ustar rjones rjones (* Thoroughly test SV-related functions.
* $Id: 100-sv.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
let () =
assert (42 = int_of_sv (sv_of_int 42));
assert (42. = float_of_sv (sv_of_float 42.));
assert (true = bool_of_sv (sv_of_bool true));
assert (false = bool_of_sv (sv_of_bool false));
assert ("42" = string_of_sv (sv_of_string "42"));
assert ("42" = string_of_sv (sv_of_int 42));
assert ("1" = string_of_sv (sv_of_bool true));
(* assert ("" = string_of_sv (sv_of_bool false)); XXX fails XXX *)
assert (sv_is_true (sv_of_bool true));
assert (sv_is_true (sv_true ()));
assert (not (sv_is_true (sv_false ())));
assert (sv_is_undef (sv_undef ()));
let sv = sv_undef () in assert (sv_type sv = SVt_NULL);
let sv = sv_of_int 42 in assert (sv_type sv = SVt_IV);
(* let sv = sv_of_float 42.1 in assert (sv_type sv = SVt_NV); XXX fails XXX*)
let sv = sv_of_string "42" in assert (sv_type sv = SVt_PV);
let sv = eval "\\\"foo\"" in assert (sv_type sv = SVt_RV);
ignore (eval "$s = 'foo'");
let sv = get_sv "s" in
assert ("foo" = string_of_sv sv);
;;
Gc.full_major ()
perl4caml-0.9.5/test/120-hv.ml 0000644 0000764 0000764 00000001310 10330373423 015221 0 ustar rjones rjones (* Thoroughly test HV-related functions.
* $Id: 120-hv.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
let () =
let hv = hv_empty () in
hv_set hv "foo" (sv_of_int 1);
hv_set hv "bar" (sv_of_int 2);
hv_set hv "foo" (sv_of_int 42);
assert (42 = int_of_sv (hv_get hv "foo"));
assert (2 = int_of_sv (hv_get hv "bar"));
assert (hv_exists hv "foo");
assert (not (hv_exists hv "baz"));
hv_clear hv;
assert (not (hv_exists hv "foo"));
assert (not (hv_exists hv "bar"));
ignore (eval "%h = ( foo => 1, bar => 2 )");
let hv = get_hv "h" in
assert (1 = int_of_sv (hv_get hv "foo"));
assert (2 = int_of_sv (hv_get hv "bar"));
assert (not (hv_exists hv "baz"));
;;
Gc.full_major ()
perl4caml-0.9.5/test/020-eval.ml 0000644 0000764 0000764 00000000253 10330373423 015537 0 ustar rjones rjones (* Simple eval.
* $Id: 020-eval.ml,v 1.1 2005/01/28 23:09:33 rich Exp $
*)
open Perl
let () =
let sv = eval "2+2" in
assert (4 = int_of_sv sv);;
Gc.full_major ()
perl4caml-0.9.5/README 0000644 0000764 0000764 00000002763 10330373424 013671 0 ustar rjones rjones perl4caml
Copyright (C) 2003 Merjis Ltd. (http://www.merjis.com/)
$Id: README,v 1.4 2005/01/28 23:09:31 rich Exp $
perl4caml allows you to use Perl code within Objective CAML (OCaml),
thus neatly side-stepping the old problem with OCaml which was that it
lacked a comprehensive set of libraries. Well now you can use any part
of CPAN in your OCaml code.
perl4caml is distributed under the GNU Library General Public License
(see file COPYING.LIB for terms and conditions).
perl4caml was mainly written by Richard W.M. Jones
(rich@annexia.org). See file AUTHORS for other contributors.
Installation
------------
(1) You will need the Perl development environment installed. I'm using
Perl 5.8.x. It is likely that earlier versions may have small
incompatibilities.
(2) Edit Makefile.config as necessary.
(3) Type 'make'.
(4) It's recommended that you run the automatic tests by using 'make test'.
You should see 'All tests succeeded.' If not, please report this
to me (rich@annexia.org). If Perl gives any warnings, such as
'Attempt to free unreferenced scalar', please also report this.
(5) Type 'make install' as root to install.
(6) Try some of the examples in the examples/ directory (some of these
require that you have certain Perl modules installed).
Documentation
-------------
See doc/ for some documentation.
To build ocamldoc (automatically generated documentation for interfaces)
type 'make html'. The output can be found by pointing your browser at
'html/index.html'.
perl4caml-0.9.5/wrappers/ 0000775 0000764 0000764 00000000000 10762251536 014656 5 ustar rjones rjones perl4caml-0.9.5/wrappers/pl_LWP_UserAgent.ml 0000644 0000764 0000764 00000010275 10762251735 020326 0 ustar rjones rjones (** Wrapper around Perl [LWP::UserAgent] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_LWP_UserAgent.ml,v 1.6 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTTP_Request
open Pl_HTTP_Response
open Pl_HTTP_Cookies
let _ = eval "use LWP::UserAgent"
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 "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 cookie_jar =
let sv = call_method sv "cookie_jar" [] in
new http_cookies sv
method set_cookie_jar (v : http_cookies) =
call_method_void sv "cookie_jar" [v#sv]
method set_cookie_jar_file filename =
let hv = hv_empty () in
hv_set hv "file" (sv_of_string filename);
call_method_void sv "cookie_jar" [hashref hv]
method requests_redirectable =
let sv = call_method sv "requests_redirectable" [] in
let av = deref_array sv in
List.map string_of_sv (list_of_av av)
method set_requests_redirectable methods =
let av = av_empty () in
List.iter (av_push av) (List.map sv_of_string methods);
call_method_void sv "requests_redirectable" [arrayref av]
method add_requests_redirectable method_ =
let sv = call_method sv "requests_redirectable" [] in
let av = deref_array sv in
av_push av (sv_of_string method_)
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 ?cookie_jar ?cookie_jar_file () =
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;
may (fun (v : http_cookies) ->
args := sv_of_string "cookie_jar" :: v#sv :: !args) cookie_jar;
may (fun v ->
let hv = hv_empty () in
hv_set hv "file" (sv_of_string v);
let sv = hashref hv in
args := sv_of_string "cookie_jar" :: sv :: !args) cookie_jar_file;
let sv = call_class_method "LWP::UserAgent" "new" !args in
new lwp_useragent sv
perl4caml-0.9.5/wrappers/.cvsignore 0000644 0000764 0000764 00000000037 10330373423 016643 0 ustar rjones rjones *.cmi
*.cmo
*.cmx
*.cma
*.cmxa
perl4caml-0.9.5/wrappers/pl_WWW_Mechanize.ml 0000644 0000764 0000764 00000020017 10762251735 020351 0 ustar rjones rjones (** Wrapper around Perl [WWW::Mechanize] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_WWW_Mechanize.ml,v 1.8 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_LWP_UserAgent
let _ = eval "use WWW::Mechanize"
class www_mechanize sv =
object (self)
inherit lwp_useragent sv
method agent_alias alias =
call_method_void sv "agent_alias" [sv_of_string alias]
method known_agent_aliases =
let svlist = call_method_array sv "known_agent_aliases" [] in
List.map string_of_sv svlist
method get url =
call_method_void sv "get" [sv_of_string url]
method reload () =
call_method_void sv "reload" []
method back () =
call_method_void sv "back" []
method follow_link ?text ?text_regex ?url ?url_regex ?url_abs ?url_abs_regex
?name ?name_regex ?tag ?tag_regex ?n () =
let args = ref [] in
let add name f = function
| None -> ()
| Some p -> args := sv_of_string name :: f p :: !args
in
add "text" sv_of_string text;
add "text_regex" sv_of_string text_regex;
add "url" sv_of_string url;
add "url_regex" sv_of_string url_regex;
add "url_abs" sv_of_string url_abs;
add "url_abs_regex" sv_of_string url_abs_regex;
add "name" sv_of_string name;
add "name_regex" sv_of_string name_regex;
add "tag" sv_of_string tag;
add "tag_regex" sv_of_string tag_regex;
add "n" sv_of_int n;
call_method_void sv "follow_link" !args
method forms =
let svlist = call_method_array sv "forms" [] in
List.map (new Pl_HTML_Form.html_form) svlist
method form_number n =
let sv = call_method sv "form_number" [sv_of_int n] in
new Pl_HTML_Form.html_form sv
method form_name name =
let sv = call_method sv "form_name" [sv_of_string name] in
new Pl_HTML_Form.html_form sv
(* XXX There is an arrayref variant of this method, but what
* it does is apparently undocumented.
*)
method field ?n name value =
let args = match n with
None -> [sv_of_string name; sv_of_string value]
| Some n -> [sv_of_string name; sv_of_string value; sv_of_int n] in
call_method_void sv "field" args
method set_fields fields =
let args = ref [] in
List.iter (fun (k, v) ->
(* Note: reversed k, v because we'll reverse the whole list.*)
args := sv_of_string v :: sv_of_string k :: !args) fields;
let args = List.rev !args in
call_method_void sv "set_fields" args
method value ?n name =
let args = match n with
None -> [sv_of_string name]
| Some n -> [sv_of_string name; sv_of_int n] in
let sv = call_method sv "value" args in
string_of_sv sv
(* XXX Doesn't support setting criteria. *)
method set_visible names =
let names = List.map sv_of_string names in
call_method_void sv "set_visible" names
method tick ?set name value =
let args = match set with
None -> [ sv_of_string name; sv_of_string value ]
| Some b -> [ sv_of_string name; sv_of_string value; sv_of_bool b ] in
call_method_void sv "tick" args
method untick name value =
call_method_void sv "untick" [ sv_of_string name; sv_of_string value ]
method click ?xy button =
let args = match xy with
None -> [ sv_of_string button ]
| Some (x, y) -> [ sv_of_string button; sv_of_int x; sv_of_int y ] in
call_method_void sv "click" args
method click1 () =
call_method_void sv "click" []
method click_button ?name ?number ?value ?xy () =
let args = ref [] in
let add name f = function
| None -> ()
| Some p -> args := sv_of_string name :: f p :: !args
in
add "name" sv_of_string name;
add "number" sv_of_int number;
add "value" sv_of_string value;
(match xy with
None -> ()
| Some (x, y) ->
args := sv_of_string "x" :: sv_of_int x ::
sv_of_string "y" :: sv_of_int y :: !args);
call_method_void sv "click" !args
method select name value =
call_method_void sv "select" [ sv_of_string name; sv_of_string value ]
method select_multiple name values =
let av = av_empty () in
List.iter (av_push av) (List.map sv_of_string values);
call_method_void sv "select" [ sv_of_string name; arrayref av ]
method submit () =
call_method_void sv "submit" []
method submit_form ?form_number ?form_name ?fields ?button ?xy () =
let args = ref [] in
let add name f = function
| None -> ()
| Some p -> args := sv_of_string name :: f p :: !args
in
add "form_number" sv_of_int form_number;
add "form_name" sv_of_string form_name;
(match fields with
| None -> ()
| Some fields ->
let hv = hv_empty () in
List.iter (
fun (name, value) ->
hv_set hv name (sv_of_string value)
) fields;
let sv = hashref hv in
args := sv_of_string "fields" :: sv :: !args
);
add "button" sv_of_string button;
(match xy with
| None -> ()
| Some (x, y) ->
args := sv_of_string "x" :: sv_of_int x ::
sv_of_string "y" :: sv_of_int y :: !args);
let sv = call_method sv "submit_form" !args in
new Pl_HTTP_Response.http_response sv
method success =
let sv = call_method sv "success" [] in
bool_of_sv sv
method uri =
let sv = call_method sv "uri" [] in
string_of_sv sv
method response =
let sv = call_method sv "response" [] in
new Pl_HTTP_Response.http_response sv
method res =
let sv = call_method sv "res" [] in
new Pl_HTTP_Response.http_response sv
method status =
let sv = call_method sv "status" [] in
int_of_sv sv
method ct =
let sv = call_method sv "ct" [] in
string_of_sv sv
method base =
let sv = call_method sv "base" [] in
string_of_sv sv
method content =
let sv = call_method sv "content" [] in
string_of_sv sv
(* method current_forms = *)
method links =
let svs = call_method_array sv "links" [] in
List.map (new www_mechanize_link) svs
method is_html =
let sv = call_method sv "is_html" [] in
bool_of_sv sv
method title =
let sv = call_method sv "title" [] in
string_of_sv sv
(* method find_link .... = *)
(* method find_all_links .... = *)
(* method add_header .... = *)
(* method delete_header .... = *)
method quiet =
let sv = call_method sv "quiet" [] in
bool_of_sv sv
method set_quiet b =
call_method_void sv "quiet" [sv_of_bool b]
(* method stack_depth ... = *)
method redirect_ok =
let sv = call_method sv "redirect_ok" [] in
bool_of_sv sv
(* method request ... = *)
(* method update_html ... = *)
end
and www_mechanize_link sv =
object (self)
method sv = sv
method url =
let sv = call_method sv "url" [] in
string_of_sv sv
method text =
let sv = call_method sv "text" [] in
string_of_sv sv
method name =
let sv = call_method sv "name" [] in
string_of_sv sv
method tag =
let sv = call_method sv "tag" [] in
string_of_sv sv
method base =
let sv = call_method sv "base" [] in
string_of_sv sv
method url_abs =
let sv = call_method sv "url_abs" [] in
string_of_sv sv
end
(* XXX Should be able to pass args to constructor of LWP::UserAgent. *)
(* XXX WWW::Mechanize has additional parameters. *)
let new_ ?autocheck () =
let args = ref [] in
let may f = function None -> () | Some v -> f v in
may (fun v ->
args := sv_of_string "autocheck" :: sv_of_bool v :: !args) autocheck;
let sv = call_class_method "WWW::Mechanize" "new" !args in
new www_mechanize sv
perl4caml-0.9.5/wrappers/pl_Net_Google_Cache.ml 0000644 0000764 0000764 00000002617 10762251735 021015 0 ustar rjones rjones (** Wrapper around Perl [Net::Google::Cache] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Net_Google_Cache.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Net::Google::Cache"
class net_google_cache sv =
object (self)
method key =
string_of_sv (call_method sv "key" [])
method set_key v =
call_method_void sv "key" [sv_of_string v]
method url =
string_of_sv (call_method sv "url" [])
method set_url v =
call_method_void sv "url" [sv_of_string v]
method get =
let sv = call_method sv "get" [] in
if sv_is_undef sv then raise Not_found;
string_of_sv sv
end
(* let new_ = ... *)
perl4caml-0.9.5/wrappers/pl_HTML_Parser.ml 0000644 0000764 0000764 00000002405 10762251735 017763 0 ustar rjones rjones (** Wrapper around Perl [HTML::Parser] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTML_Parser.ml,v 1.5 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use HTML::Parser"
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
perl4caml-0.9.5/wrappers/pl_URI.ml 0000644 0000764 0000764 00000005400 10762251735 016340 0 ustar rjones rjones (** Wrapper around Perl [URI] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_URI.ml,v 1.6 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use URI"
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 set_no_fragment () =
call_method_void sv "fragment" [sv_undef ()]
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])
method host =
string_of_sv (call_method sv "host" [])
method set_host host =
call_method_void sv "host" [sv_of_string host]
method port =
string_of_sv (call_method sv "port" [])
method set_port port =
call_method_void sv "port" [sv_of_string port]
method host_port =
string_of_sv (call_method sv "host_port" [])
method set_host_port host_port =
call_method_void sv "host_port" [sv_of_string host_port]
method default_port =
int_of_sv (call_method sv "default_port" [])
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
let new_abs str base =
let sv = call_class_method "URI" "new_abs" [sv_of_string str;
sv_of_string base] in
new uri sv
perl4caml-0.9.5/wrappers/pl_HTTP_Message.ml 0000644 0000764 0000764 00000002302 10762251735 020122 0 ustar rjones rjones (** Wrapper around Perl [HTTP::Message] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTTP_Message.ml,v 1.5 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTTP_Headers
let _ = eval "use HTTP::Message"
class http_message sv =
object (self)
inherit http_headers sv
method content =
string_of_sv (call_method sv "content" [])
method set_content content =
call_method_void sv "set_content" [sv_of_string content]
end
perl4caml-0.9.5/wrappers/pl_HTTP_Response.ml 0000644 0000764 0000764 00000004072 10762251735 020342 0 ustar rjones rjones (** Wrapper around Perl [HTTP::Response] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTTP_Response.ml,v 1.5 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTTP_Message
open Pl_HTTP_Request
let _ = eval "use HTTP::Response"
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 request =
new http_request (call_method sv "request" [])
method set_request (req : http_request) =
call_method_void sv "request" [req#sv]
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_ ... *)
perl4caml-0.9.5/wrappers/pl_Date_Calc.ml 0000644 0000764 0000764 00000005653 10762251735 017512 0 ustar rjones rjones (** Wrapper around Perl [Date::Calc] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Date_Calc.ml,v 1.2 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Date::Calc qw()"
let days_in_year year month =
int_of_sv (call ~fn:"Date::Calc::Days_in_Year"
[sv_of_int year; sv_of_int month])
let days_in_month year month =
int_of_sv (call ~fn:"Date::Calc::Days_in_Month"
[sv_of_int year; sv_of_int month])
let weeks_in_year year =
int_of_sv (call ~fn:"Date::Calc::Weeks_in_Year" [sv_of_int year])
let leap_year year =
bool_of_sv (call ~fn:"Date::Calc::leap_year" [sv_of_int year])
let check_date year month day =
bool_of_sv (call ~fn:"Date::Calc::check_date"
[sv_of_int year; sv_of_int month; sv_of_int day])
let check_time hour min sec =
bool_of_sv (call ~fn:"Date::Calc::check_time"
[sv_of_int hour; sv_of_int min; sv_of_int sec])
let check_business_date year week dow =
bool_of_sv (call ~fn:"Date::Calc::check_business_date"
[sv_of_int year; sv_of_int week; sv_of_int dow])
let day_of_year year month day =
int_of_sv (call ~fn:"Date::Calc::Day_of_Year"
[sv_of_int year; sv_of_int month; sv_of_int day])
let date_to_days year month day =
int_of_sv (call ~fn:"Date::Calc::Date_to_Days"
[sv_of_int year; sv_of_int month; sv_of_int day])
let day_of_week year month day =
int_of_sv (call ~fn:"Date::Calc::Day_of_Week"
[sv_of_int year; sv_of_int month; sv_of_int day])
let week_number year month day =
int_of_sv (call ~fn:"Date::Calc::Week_Number"
[sv_of_int year; sv_of_int month; sv_of_int day])
let week_of_year year month day =
let r = call_array ~fn:"Date::Calc::Week_of_Year"
[sv_of_int year; sv_of_int month; sv_of_int day] in
match r with
[week; year] -> int_of_sv week, int_of_sv year
| _ -> failwith "Pl_Date_Calc: week_of_year: unexpected return value"
let monday_of_week week year =
let r = call_array ~fn:"Date::Calc::Monday_of_Week"
[sv_of_int week; sv_of_int year] in
match r with
[year; month; day] -> int_of_sv year, int_of_sv month, int_of_sv day
| _ -> failwith "Pl_Date_Calc: monday_of_week: unexpected return value"
(* at this point I got bored ... - RWMJ *)
perl4caml-0.9.5/wrappers/pl_Net_Google_Search.ml 0000644 0000764 0000764 00000005303 10762251735 021212 0 ustar rjones rjones (** Wrapper around Perl [Net::Google::Search] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Net_Google_Search.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_Net_Google_Response
let _ = eval "use Net::Google::Search"
class net_google_search sv =
object (self)
method key =
string_of_sv (call_method sv "key" [])
method set_key v =
call_method_void sv "key" [sv_of_string v]
method query =
string_of_sv (call_method sv "query" [])
method set_query v =
call_method_void sv "query" [sv_of_string v]
method starts_at =
int_of_sv (call_method sv "starts_at" [])
method set_starts_at v =
call_method_void sv "starts_at" [sv_of_int v]
method max_results =
int_of_sv (call_method sv "max_results" [])
method set_max_results v =
call_method_void sv "max_results" [sv_of_int v]
method restrict types =
string_of_sv (call_method sv "restrict" (List.map sv_of_string types))
method filter =
bool_of_sv (call_method sv "filter" [])
method set_filter v =
call_method_void sv "filter" [sv_of_bool v]
method safe =
bool_of_sv (call_method sv "safe" [])
method set_safe v =
call_method_void sv "safe" [sv_of_bool v]
method lr langs =
string_of_sv (call_method sv "lr" (List.map sv_of_string langs))
method ie encs =
string_of_sv (call_method sv "ie" (List.map sv_of_string encs))
method oe encs =
string_of_sv (call_method sv "oe" (List.map sv_of_string encs))
method return_estimatedTotal =
bool_of_sv (call_method sv "return_estimatedTotal" [])
method set_return_estimatedTotal v =
call_method_void sv "return_estimatedTotal" [sv_of_bool v]
method response =
let sv = call_method sv "response" [] in
let av = deref_array sv in
av_map (fun sv -> new net_google_response sv) av
method results =
let sv = call_method sv "results" [] in
let av = deref_array sv in
av_map (fun sv -> new net_google_response sv) av
end
(* let new_ = ... *)
perl4caml-0.9.5/wrappers/pl_HTML_Form.ml 0000644 0000764 0000764 00000003754 10762251735 017442 0 ustar rjones rjones (** Wrapper around Perl [HTML::Form] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTML_Form.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTTP_Response
let _ = eval "use HTML::Form"
class html_form (sv : sv) =
object (self)
method sv = sv
method attr name =
let sv = call_method sv "attr" [sv_of_string name] in
(* sv_is_undef doesn't work properly XXX *)
if sv_is_undef sv then None else Some (string_of_sv sv)
method set_attr name value =
call_method_void sv "attr" [sv_of_string name; sv_of_string value]
(* The following isn't a real method. The return type of HTML::Form->inputs
* isn't documented, but I wanted a list of input names (as strings) anyway.
*)
method input_names =
let inputs = call_method_array sv "inputs" [] in
let names = List.map (fun sv -> call_method sv "name" []) inputs in
List.map string_of_sv names
end
let parse_document html_document base_uri =
let svlist = call_class_method_array "HTML::Form" "parse"
[sv_of_string html_document; sv_of_string base_uri] in
List.map (new html_form) svlist
let parse_response (res : http_response) =
let svlist = call_class_method_array "HTML::Form" "parse" [res#sv] in
List.map (new html_form) svlist
perl4caml-0.9.5/wrappers/pl_Net_Google_Spelling.ml 0000644 0000764 0000764 00000002515 10762251735 021564 0 ustar rjones rjones (** Wrapper around Perl [Net::Google::Spelling] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Net_Google_Spelling.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Net::Google::Spelling"
class net_google_spelling sv =
object (self)
method key =
string_of_sv (call_method sv "key" [])
method set_key v =
call_method_void sv "key" [sv_of_string v]
method phrase phrases =
string_of_sv (call_method sv "phrase" (List.map sv_of_string phrases))
method suggest =
string_of_sv (call_method sv "suggest" [])
end
(* let new_ = ... *)
perl4caml-0.9.5/wrappers/pl_HTTP_Headers.ml 0000644 0000764 0000764 00000002411 10762251735 020112 0 ustar rjones rjones (** Wrapper around Perl [HTTP::Message] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTTP_Headers.ml,v 1.3 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use HTTP::Headers"
class http_headers sv =
object (self)
method sv = sv
method header key =
string_of_sv (call_method sv "header" [sv_of_string key])
method set_header key value =
call_method_void sv "header" [sv_of_string key; sv_of_string value]
method as_string =
string_of_sv (call_method sv "as_string" [])
end
perl4caml-0.9.5/wrappers/pl_HTML_Element.ml 0000644 0000764 0000764 00000006223 10762251735 020122 0 ustar rjones rjones (** Wrapper around Perl [HTML::Element] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTML_Element.ml,v 1.5 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use HTML::Element"
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 ->
(* Not very satisfactory, but sv_type fails to discern the type
* for some reason. XXX
*)
let str = string_of_sv c in
let marker = "HTML::Element=HASH(" in
let marker_len = String.length marker in
if String.length str > marker_len &&
String.sub str 0 marker_len = marker then
Element (new html_element c)
else
String (string_of_sv c)
) 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
perl4caml-0.9.5/wrappers/pl_HTTP_Cookies.ml 0000644 0000764 0000764 00000004214 10762251735 020136 0 ustar rjones rjones (** Wrapper around Perl [HTTP::Cookies] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTTP_Cookies.ml,v 1.2 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use HTTP::Cookies"
class http_cookies sv =
object (self)
method sv = sv
method save ?filename () =
let args = match filename with
None -> []
| Some filename -> [sv_of_string filename] in
call_method_void sv "save" args
method load ?filename () =
let args = match filename with
None -> []
| Some filename -> [sv_of_string filename] in
call_method_void sv "load" args
method revert () =
call_method_void sv "revert" []
method as_string ?skip_discardables () =
let args = match skip_discardables with
None -> []
| Some b -> [sv_of_bool b] in
string_of_sv (call_method sv "as_string" args)
end
let new_ ?file ?autosave ?ignore_discard ?hide_cookie2 () =
let args = ref [] in
let may f = function None -> () | Some v -> f v in
may (fun v ->
args := sv_of_string "file" :: sv_of_string v :: !args) file;
may (fun v ->
args := sv_of_string "autosave" :: sv_of_bool v :: !args) autosave;
may (fun v ->
args := sv_of_string "ignore_discard" :: sv_of_bool v :: !args)
ignore_discard;
may (fun v ->
args := sv_of_string "hide_cookie2" :: sv_of_bool v :: !args)
hide_cookie2;
let sv = call_class_method "HTTP::Cookies" "new" !args in
new http_cookies sv
perl4caml-0.9.5/wrappers/pl_HTML_TreeBuilder.ml 0000644 0000764 0000764 00000003214 10762251735 020734 0 ustar rjones rjones (** Wrapper around Perl [HTML::TreeBuilder] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTML_TreeBuilder.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTML_Parser
open Pl_HTML_Element
let _ = eval "use HTML::TreeBuilder"
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
perl4caml-0.9.5/wrappers/pl_Date_Format.ml 0000644 0000764 0000764 00000004054 10762251735 020072 0 ustar rjones rjones (** Wrapper around Perl [Date::Format] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Date_Format.ml,v 1.2 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Date::Format qw()"
let language lang =
call_class_method_void "Date::Format" "language" [sv_of_string lang]
(* This is just provided for your convenience so you can pass the resulting
* list of SVs directly to the second argument of {!Pl_Date_Format.strftime}.
*)
let localtime () =
call_array ~fn:"localtime" []
let time2str ?zone templ time =
let args =
[sv_of_string templ; sv_of_float time] @
match zone with
None -> []
| Some zone -> [sv_of_string zone] in
string_of_sv (call ~fn:"Date::Format::time2str" args)
let strftime ?zone templ time =
let args =
(sv_of_string templ :: time) @
match zone with
None -> []
| Some zone -> [sv_of_string zone] in
string_of_sv (call ~fn:"Date::Format::strftime" args)
let ctime ?zone time =
let args =
[sv_of_float time] @
match zone with
None -> []
| Some zone -> [sv_of_string zone] in
string_of_sv (call ~fn:"Date::Format::ctime" args)
let asctime ?zone time =
let args =
[sv_of_float time] @
match zone with
None -> []
| Some zone -> [sv_of_string zone] in
string_of_sv (call ~fn:"Date::Format::asctime" args)
perl4caml-0.9.5/wrappers/pl_HTTP_Request_Common.ml 0000644 0000764 0000764 00000003261 10762251735 021503 0 ustar rjones rjones (** Wrapper around Perl [HTTP::Request::Common] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTTP_Request_Common.ml,v 1.2 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTTP_Request
let _ = eval "use HTTP::Request::Common"
let get, head, put =
let dofn fn url headers =
let args =
sv_of_string url ::
List.fold_right (fun (k, v) rest ->
sv_of_string k :: sv_of_string v :: rest)
headers [] in
new http_request (call ~fn args)
in
let get = dofn "GET" in
let head = dofn "HEAD" in
let put = dofn "PUT" in
get, head, put
let post url ?form headers =
let hv = hv_empty () in
(match form with
| None -> ()
| Some xs -> List.iter (fun (k, v) -> hv_set hv k (sv_of_string v)) xs);
let args =
sv_of_string url :: hashref hv ::
List.fold_right (fun (k, v) rest ->
sv_of_string k :: sv_of_string v :: rest)
headers [] in
new http_request (call ~fn:"POST" args)
perl4caml-0.9.5/wrappers/pl_HTTP_Request.ml 0000644 0000764 0000764 00000003616 10762251735 020177 0 ustar rjones rjones (** Wrapper around Perl [HTTP::Request] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_HTTP_Request.ml,v 1.5 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_HTTP_Message
open Pl_URI
let _ = eval "use HTTP::Request"
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 uri =
string_of_sv (call_method sv "uri" [])
method set_uri uri =
call_method_void sv "uri" [sv_of_string uri]
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
perl4caml-0.9.5/wrappers/pl_Template.ml 0000644 0000764 0000764 00000016445 10762251735 017467 0 ustar rjones rjones (** Wrapper around Perl [Template] class (Template Toolkit). *)
(* Copyright (C) 2003 Dave Benjamin .
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Template.ml,v 1.3 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Template"
exception Not_implemented
exception Error of string
module Variant =
struct
type t =
| Null
| String of string
| Int of int
| Float of float
| Bool of bool
| Array of t list
| Hash of (string * t) list;;
end
let rec sv_of_variant = function
| Variant.Null -> sv_undef ()
| Variant.String s -> sv_of_string s
| Variant.Int i -> sv_of_int i
| Variant.Float f -> sv_of_float f
| Variant.Bool b -> sv_of_bool b
| Variant.Array xs -> arrayref (av_of_sv_list (List.map sv_of_variant xs))
| Variant.Hash xs -> hashref
(let hv = hv_empty () in
List.iter (fun (k, v) -> hv_set hv k (sv_of_variant v)) xs;
hv
);;
let hv_of_string_pair_list pairs =
let hv = hv_empty () in
List.iter (fun (k, v) -> hv_set hv k (sv_of_string v)) pairs;
hv
class template sv =
object (self)
method process file vars =
let output = sv_of_string "" in
let args = [sv_of_string file; sv_of_variant vars; scalarref output] in
let result = call_method sv "process" args in
if not (sv_is_true result) then
raise (Error self#error)
else
string_of_sv output
method error =
string_of_sv (call_method sv "error" [])
end
let may f = function None -> () | Some v -> f v
let new_ ?start_tag ?end_tag ?tag_style ?pre_chomp ?post_chomp ?trim
?interpolate ?anycase ?include_path ?delimiter ?absolute ?relative
?default ?blocks ?auto_reset ?recursion ?variables ?constants
?constant_namespace ?namespace ?pre_process ?post_process ?process
?wrapper ?error ?errors ?eval_perl ?output ?output_path ?debug ?debug_format
?cache_size ?compile_ext ?compile_dir ?plugins ?plugin_base ?load_perl
?filters ?v1dollar ?load_templates ?load_plugins ?load_filters
?tolerant ?service ?context ?stash ?parser ?grammar () =
let args = ref [] in
may (fun v ->
args := sv_of_string "START_TAG" :: sv_of_string v :: !args) start_tag;
may (fun v ->
args := sv_of_string "END_TAG" :: sv_of_string v :: !args) end_tag;
may (fun v ->
args := sv_of_string "TAG_STYLE" :: sv_of_string v :: !args) tag_style;
may (fun v ->
args := sv_of_string "PRE_CHOMP" :: sv_of_bool v :: !args) pre_chomp;
may (fun v ->
args := sv_of_string "POST_CHOMP" :: sv_of_bool v :: !args) post_chomp;
may (fun v ->
args := sv_of_string "TRIM" :: sv_of_bool v :: !args) trim;
may (fun v ->
args := sv_of_string "INTERPOLATE" :: sv_of_bool v :: !args) interpolate;
may (fun v ->
args := sv_of_string "ANYCASE" :: sv_of_bool v :: !args) anycase;
may (fun v ->
args := sv_of_string "INCLUDE_PATH" :: arrayref (av_of_string_list v) :: !args) include_path;
may (fun v ->
args := sv_of_string "DELIMITER" :: sv_of_string v :: !args) delimiter;
may (fun v ->
args := sv_of_string "ABSOLUTE" :: sv_of_bool v :: !args) absolute;
may (fun v ->
args := sv_of_string "RELATIVE" :: sv_of_bool v :: !args) relative;
may (fun v ->
args := sv_of_string "DEFAULT" :: sv_of_string v :: !args) default;
may (fun v ->
args := sv_of_string "BLOCKS" :: hashref (hv_of_string_pair_list v) :: !args) blocks;
may (fun v ->
args := sv_of_string "AUTO_RESET" :: sv_of_bool v :: !args) auto_reset;
may (fun v ->
args := sv_of_string "RECURSION" :: sv_of_bool v :: !args) recursion;
may (fun v ->
args := sv_of_string "VARIABLES" :: sv_of_variant v :: !args) variables;
may (fun v ->
args := sv_of_string "CONSTANTS" :: sv_of_variant v :: !args) constants;
may (fun v ->
args := sv_of_string "CONSTANT_NAMESPACE" :: sv_of_string v :: !args) constant_namespace;
may (fun v ->
args := sv_of_string "NAMESPACE" :: sv_of_variant v :: !args) namespace;
may (fun v ->
args := sv_of_string "PRE_PROCESS" :: arrayref (av_of_string_list v) :: !args) pre_process;
may (fun v ->
args := sv_of_string "POST_PROCESS" :: arrayref (av_of_string_list v) :: !args) post_process;
may (fun v ->
args := sv_of_string "PROCESS" :: arrayref (av_of_string_list v) :: !args) process;
may (fun v ->
args := sv_of_string "WRAPPER" :: arrayref (av_of_string_list v) :: !args) wrapper;
may (fun v ->
args := sv_of_string "ERROR" :: sv_of_string v :: !args) error;
may (fun v ->
args := sv_of_string "ERRORS" :: hashref (hv_of_string_pair_list v) :: !args) errors;
may (fun v ->
args := sv_of_string "EVAL_PERL" :: sv_of_bool v :: !args) eval_perl;
may (fun v ->
raise Not_implemented) output;
may (fun v ->
raise Not_implemented) output_path;
may (fun v ->
args := sv_of_string "DEBUG" :: sv_of_string v :: !args) debug;
may (fun v ->
args := sv_of_string "DEBUG_FORMAT" :: sv_of_string v :: !args) debug_format;
may (fun v ->
args := sv_of_string "CACHE_SIZE" :: sv_of_int v :: !args) cache_size;
may (fun v ->
args := sv_of_string "COMPILE_EXT" :: sv_of_string v :: !args) compile_ext;
may (fun v ->
args := sv_of_string "COMPILE_DIR" :: sv_of_string v :: !args) compile_dir;
may (fun v ->
args := sv_of_string "PLUGINS" :: hashref (hv_of_string_pair_list v) :: !args) plugins;
may (fun v ->
args := sv_of_string "PLUGIN_BASE" :: arrayref (av_of_string_list v) :: !args) plugin_base;
may (fun v ->
args := sv_of_string "LOAD_PERL" :: sv_of_bool v :: !args) load_perl;
may (fun v ->
raise Not_implemented) filters;
may (fun v ->
args := sv_of_string "V1DOLLAR" :: sv_of_bool v :: !args) v1dollar;
may (fun v ->
raise Not_implemented) load_templates;
may (fun v ->
raise Not_implemented) load_plugins;
may (fun v ->
raise Not_implemented) load_filters;
may (fun v ->
args := sv_of_string "TOLERANT" :: sv_of_bool v :: !args) tolerant;
may (fun v ->
raise Not_implemented) service;
may (fun v ->
raise Not_implemented) context;
may (fun v ->
raise Not_implemented) stash;
may (fun v ->
raise Not_implemented) parser;
may (fun v ->
raise Not_implemented) grammar;
let sv = call_class_method "Template" "new" !args in
new template sv
perl4caml-0.9.5/wrappers/pl_Net_Google_Response.ml 0000644 0000764 0000764 00000004710 10762251735 021604 0 ustar rjones rjones (** Wrapper around Perl [Net::Google::Reponse] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Net_Google_Response.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Net::Google::Response"
class net_google_response sv =
object (self)
method documentFiltering =
bool_of_sv (call_method sv "documentFiltering" [])
method searchComments =
string_of_sv (call_method sv "searchComments" [])
method estimateTotalResultsNumber =
int_of_sv (call_method sv "estimateTotalResultsNumber" [])
method estimateIsExact =
bool_of_sv (call_method sv "estimateIsExact" [])
method searchQuery =
string_of_sv (call_method sv "searchQuery" [])
method startIndex =
int_of_sv (call_method sv "startIndex" [])
method endIndex =
int_of_sv (call_method sv "endIndex" [])
method searchTips =
string_of_sv (call_method sv "searchTips" [])
method directoryCategories =
let sv = call_method sv "directoryCategories" [] in
let av = deref_array sv in
av_map (fun sv -> new net_google_response sv) av
method searchTime =
float_of_sv (call_method sv "searchTime" [])
method toString =
string_of_sv (call_method sv "toString" [])
method title =
string_of_sv (call_method sv "title" [])
method url =
string_of_sv (call_method sv "URL" [])
method snippet =
string_of_sv (call_method sv "snippet" [])
method cachedSize =
string_of_sv (call_method sv "cachedSize" [])
method directoryTitle =
string_of_sv (call_method sv "directoryTitle" [])
method summary =
string_of_sv (call_method sv "summary" [])
method hostName =
string_of_sv (call_method sv "hostName" [])
(* method directoryCategory *)
end
(* let new_ = ... *)
perl4caml-0.9.5/wrappers/pl_Date_Parse.ml 0000644 0000764 0000764 00000002640 10330373423 017701 0 ustar rjones rjones (** Wrapper around Perl [Date::Parse] class.
*
* Copyright (C) 2003 Merjis Ltd.
*
* $Id: pl_Date_Parse.ml,v 1.1 2003/11/19 16:28:23 rich Exp $
*)
open Perl
let _ = eval "use Date::Parse qw()"
(* XXX languages not supported yet - when it is supported, it'll be in
* [pl_Date_Language] anyway, not here -- RWMJ
*)
let str2time ?zone date =
let args =
[sv_of_string date] @
match zone with
None -> []
| Some zone -> [sv_of_string zone] in
let sv = call ~fn:"Date::Parse::str2time" args in
if sv_is_undef sv then
invalid_arg "Date::Parse: Could not parse date";
float_of_sv sv
let strptime ?zone date =
let args =
[sv_of_string date] @
match zone with
None -> []
| Some zone -> [sv_of_string zone] in
let svs = call_array ~fn:"Date::Parse::strptime" args in
match svs with
[] -> invalid_arg "Date::Parse: Could not parse date"
| [ ss; mm; hh; day; month; year; zone ] ->
((if sv_is_undef ss then None else Some (int_of_sv ss)),
(if sv_is_undef mm then None else Some (int_of_sv mm)),
(if sv_is_undef hh then None else Some (int_of_sv hh)),
(if sv_is_undef day then None else Some (int_of_sv day)),
(if sv_is_undef month then None else Some (int_of_sv month)),
(if sv_is_undef year then None else Some (int_of_sv year)),
(if sv_is_undef zone then None else Some (string_of_sv zone)))
| _ ->
failwith "Pl_Date_Parse: invalid list returned by strptime"
perl4caml-0.9.5/wrappers/pl_Net_Google.ml 0000644 0000764 0000764 00000005764 10762251735 017740 0 ustar rjones rjones (** Wrapper around Perl [Net::Google] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Net_Google.ml,v 1.4 2008-03-01 13:02:21 rich Exp $
*)
open Perl
open Pl_Net_Google_Cache
open Pl_Net_Google_Search
open Pl_Net_Google_Spelling
let _ = eval "use Net::Google"
let may f = function None -> () | Some v -> f v
class net_google sv =
object (self)
method search ?key ?starts_at ?max_results ?lr ?ie ?oe ?safe ?filter () =
let args = ref [] in
may (fun v ->
args := sv_of_string "key" :: sv_of_string v :: !args) key;
may (fun v ->
args := sv_of_string "starts_at" :: sv_of_int v :: !args) starts_at;
may (fun v ->
args := sv_of_string "max_results" :: sv_of_int v :: !args)
max_results;
may (fun v ->
args := sv_of_string "lr" :: sv_of_string v :: !args) lr;
may (fun v ->
args := sv_of_string "ie" :: sv_of_string v :: !args) ie;
may (fun v ->
args := sv_of_string "oe" :: sv_of_string v :: !args) oe;
may (fun v ->
args := sv_of_string "safe" :: sv_of_bool v :: !args) safe;
may (fun v ->
args := sv_of_string "filter" :: sv_of_bool v :: !args) filter;
let sv = call_method sv "search" !args in
new net_google_search sv
method spelling ?key ?phrase ?debug () =
let args = ref [] in
may (fun v ->
args := sv_of_string "key" :: sv_of_string v :: !args) key;
may (fun v ->
args := sv_of_string "phrase" :: sv_of_string v :: !args) phrase;
may (fun v ->
args := sv_of_string "debug" :: sv_of_int v :: !args) debug;
let sv = call_method sv "spelling" !args in
new net_google_spelling sv
method cache ?key ?url ?debug () =
let args = ref [] in
may (fun v ->
args := sv_of_string "key" :: sv_of_string v :: !args) key;
may (fun v ->
args := sv_of_string "url" :: sv_of_string v :: !args) url;
may (fun v ->
args := sv_of_string "debug" :: sv_of_int v :: !args) debug;
let sv = call_method sv "cache" !args in
new net_google_cache sv
end
let new_ ?key ?debug () =
let args = ref [] in
may (fun v ->
args := sv_of_string "key" :: sv_of_string v :: !args) key;
may (fun v ->
args := sv_of_string "debug" :: sv_of_int v :: !args) debug;
let sv = call_class_method "Net::Google" "new" !args in
new net_google sv
perl4caml-0.9.5/wrappers/pl_Data_Dumper.ml 0000644 0000764 0000764 00000002430 10762251735 020066 0 ustar rjones rjones (** Wrapper around Perl [Data::Dumper] class. *)
(* Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: pl_Data_Dumper.ml,v 1.3 2008-03-01 13:02:21 rich Exp $
*)
open Perl
let _ = eval "use Data::Dumper"
class data_dumper (sv : sv) =
object (self)
method sv = sv
end
let new_ r =
let sv = call_class_method "Data::Dumper" "new" [r] in
new data_dumper sv
let dump r =
string_of_sv (call_class_method "Data::Dumper" "Dump" [r])
let dump_hv hv =
dump (arrayref (av_of_sv_list [hashref hv]))
let dump_av av =
dump (arrayref av)
perl4caml-0.9.5/.depend 0000644 0000764 0000764 00000007272 10762251535 014260 0 ustar rjones rjones perl.cmo: perl.cmi
perl.cmx: perl.cmi
examples/google.cmo: wrappers/pl_Net_Google.cmo
examples/google.cmx: wrappers/pl_Net_Google.cmx
examples/loadpage.cmo: wrappers/pl_LWP_UserAgent.cmo \
wrappers/pl_HTTP_Request.cmo wrappers/pl_HTML_TreeBuilder.cmo \
wrappers/pl_HTML_Element.cmo
examples/loadpage.cmx: wrappers/pl_LWP_UserAgent.cmx \
wrappers/pl_HTTP_Request.cmx wrappers/pl_HTML_TreeBuilder.cmx \
wrappers/pl_HTML_Element.cmx
examples/parsedate.cmo: wrappers/pl_Date_Parse.cmo \
wrappers/pl_Date_Format.cmo
examples/parsedate.cmx: wrappers/pl_Date_Parse.cmx \
wrappers/pl_Date_Format.cmx
examples/test.cmo: perl.cmi
examples/test.cmx: perl.cmx
wrappers/pl_Data_Dumper.cmo: perl.cmi
wrappers/pl_Data_Dumper.cmx: perl.cmx
wrappers/pl_Date_Calc.cmo: perl.cmi
wrappers/pl_Date_Calc.cmx: perl.cmx
wrappers/pl_Date_Format.cmo: perl.cmi
wrappers/pl_Date_Format.cmx: perl.cmx
wrappers/pl_Date_Parse.cmo: perl.cmi
wrappers/pl_Date_Parse.cmx: perl.cmx
wrappers/pl_HTML_Element.cmo: perl.cmi
wrappers/pl_HTML_Element.cmx: perl.cmx
wrappers/pl_HTML_Form.cmo: wrappers/pl_HTTP_Response.cmo perl.cmi
wrappers/pl_HTML_Form.cmx: wrappers/pl_HTTP_Response.cmx perl.cmx
wrappers/pl_HTML_Parser.cmo: perl.cmi
wrappers/pl_HTML_Parser.cmx: perl.cmx
wrappers/pl_HTML_TreeBuilder.cmo: wrappers/pl_HTML_Parser.cmo \
wrappers/pl_HTML_Element.cmo perl.cmi
wrappers/pl_HTML_TreeBuilder.cmx: wrappers/pl_HTML_Parser.cmx \
wrappers/pl_HTML_Element.cmx perl.cmx
wrappers/pl_HTTP_Cookies.cmo: perl.cmi
wrappers/pl_HTTP_Cookies.cmx: perl.cmx
wrappers/pl_HTTP_Headers.cmo: perl.cmi
wrappers/pl_HTTP_Headers.cmx: perl.cmx
wrappers/pl_HTTP_Message.cmo: wrappers/pl_HTTP_Headers.cmo perl.cmi
wrappers/pl_HTTP_Message.cmx: wrappers/pl_HTTP_Headers.cmx perl.cmx
wrappers/pl_HTTP_Request_Common.cmo: wrappers/pl_HTTP_Request.cmo perl.cmi
wrappers/pl_HTTP_Request_Common.cmx: wrappers/pl_HTTP_Request.cmx perl.cmx
wrappers/pl_HTTP_Request.cmo: wrappers/pl_URI.cmo \
wrappers/pl_HTTP_Message.cmo perl.cmi
wrappers/pl_HTTP_Request.cmx: wrappers/pl_URI.cmx \
wrappers/pl_HTTP_Message.cmx perl.cmx
wrappers/pl_HTTP_Response.cmo: wrappers/pl_HTTP_Request.cmo \
wrappers/pl_HTTP_Message.cmo perl.cmi
wrappers/pl_HTTP_Response.cmx: wrappers/pl_HTTP_Request.cmx \
wrappers/pl_HTTP_Message.cmx perl.cmx
wrappers/pl_LWP_UserAgent.cmo: wrappers/pl_HTTP_Response.cmo \
wrappers/pl_HTTP_Request.cmo wrappers/pl_HTTP_Cookies.cmo perl.cmi
wrappers/pl_LWP_UserAgent.cmx: wrappers/pl_HTTP_Response.cmx \
wrappers/pl_HTTP_Request.cmx wrappers/pl_HTTP_Cookies.cmx perl.cmx
wrappers/pl_Net_Google_Cache.cmo: perl.cmi
wrappers/pl_Net_Google_Cache.cmx: perl.cmx
wrappers/pl_Net_Google.cmo: wrappers/pl_Net_Google_Spelling.cmo \
wrappers/pl_Net_Google_Search.cmo wrappers/pl_Net_Google_Cache.cmo \
perl.cmi
wrappers/pl_Net_Google.cmx: wrappers/pl_Net_Google_Spelling.cmx \
wrappers/pl_Net_Google_Search.cmx wrappers/pl_Net_Google_Cache.cmx \
perl.cmx
wrappers/pl_Net_Google_Response.cmo: perl.cmi
wrappers/pl_Net_Google_Response.cmx: perl.cmx
wrappers/pl_Net_Google_Search.cmo: wrappers/pl_Net_Google_Response.cmo \
perl.cmi
wrappers/pl_Net_Google_Search.cmx: wrappers/pl_Net_Google_Response.cmx \
perl.cmx
wrappers/pl_Net_Google_Spelling.cmo: perl.cmi
wrappers/pl_Net_Google_Spelling.cmx: perl.cmx
wrappers/pl_Template.cmo: perl.cmi
wrappers/pl_Template.cmx: perl.cmx
wrappers/pl_URI.cmo: perl.cmi
wrappers/pl_URI.cmx: perl.cmx
wrappers/pl_WWW_Mechanize.cmo: wrappers/pl_LWP_UserAgent.cmo \
wrappers/pl_HTTP_Response.cmo wrappers/pl_HTML_Form.cmo perl.cmi
wrappers/pl_WWW_Mechanize.cmx: wrappers/pl_LWP_UserAgent.cmx \
wrappers/pl_HTTP_Response.cmx wrappers/pl_HTML_Form.cmx perl.cmx
perl4caml-0.9.5/perl_c.c 0000644 0000764 0000764 00000063344 10762251735 014434 0 ustar rjones rjones /* Interface to Perl from OCaml.
Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: perl_c.c,v 1.25 2008-03-01 13:02:21 rich Exp $
*/
#include
#include
#include
#include
#include
#define CAML_NAME_SPACE 1
#include
#include
#include
#include
#include
#include
#include
#include
/* Perl requires the interpreter to be called literally 'my_perl'! */
static PerlInterpreter *my_perl;
/* Get the concrete value from an optional field. */
static value unoption (value option, value deflt);
/* Wrap up an arbitrary void pointer in an opaque OCaml object. */
static value Val_voidptr (void *ptr);
/* Unwrap an arbitrary void pointer from an opaque OCaml object. */
#define Voidptr_val(type,rv) ((type *) Field ((rv), 0))
#if PERL4CAML_REFCOUNTING_EXPERIMENTAL
/* Unwrap a custom block. */
#define Xv_val(rv) (*((void **)Data_custom_val(rv)))
/* Wrap up an SV, AV or HV in a custom OCaml object which will decrement
* the reference count on finalization.
*/
static value Val_xv (SV *sv);
#else
#define Xv_val(rv) Voidptr_val (SV, (rv))
#define Val_xv(sv) Val_voidptr ((sv))
#endif
/* Hide Perl types in opaque OCaml objects. */
#define Val_perl(pl) (Val_voidptr ((pl)))
#define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv)))
#define Val_sv(sv) (Val_xv ((sv)))
#define Sv_val(svv) ((SV *) Xv_val (svv))
#define Val_av(av) (Val_xv ((SV *)(av)))
#define Av_val(avv) ((AV *) Xv_val (avv))
#define Val_hv(hv) (Val_xv ((SV *)(hv)))
#define Hv_val(hvv) ((HV *) Xv_val (hvv))
#define Val_he(he) (Val_voidptr ((he)))
#define He_val(hev) (Voidptr_val (HE, (hev)))
static void
xs_init (pTHX)
{
char *file = __FILE__;
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}
CAMLprim value
perl4caml_init (value unit)
{
CAMLparam1 (unit);
int argc = 4;
static char *argv[] = { "", "-w", "-e", "0", NULL };
PERL_SYS_INIT (&argc, &argv);
my_perl = perl_alloc ();
perl_construct (my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse (my_perl, xs_init, argc, argv, (char **) NULL);
/*perl_run (my_perl);*/
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_int_of_sv (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
CAMLreturn (Val_int (SvIV (sv)));
}
CAMLprim value
perl4caml_sv_of_int (value iv)
{
CAMLparam1 (iv);
CAMLreturn (Val_sv (newSViv (Int_val (iv))));
}
CAMLprim value
perl4caml_float_of_sv (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
CAMLlocal1 (f);
f = caml_copy_double (SvNV (sv));
CAMLreturn (f);
}
CAMLprim value
perl4caml_sv_of_float (value fv)
{
CAMLparam1 (fv);
CAMLreturn (Val_sv (newSVnv (Double_val (fv))));
}
CAMLprim value
perl4caml_string_of_sv (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
char *str;
STRLEN len;
CAMLlocal1 (strv);
str = SvPV (sv, len);
strv = caml_alloc_string (len);
memcpy (String_val (strv), str, len);
CAMLreturn (strv);
}
CAMLprim value
perl4caml_sv_of_string (value strv)
{
CAMLparam1 (strv);
CAMLreturn (Val_sv (newSVpv (String_val (strv), caml_string_length (strv))));
}
CAMLprim value
perl4caml_sv_is_true (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
CAMLreturn (SvTRUE (sv) ? Val_true : Val_false);
}
CAMLprim value
perl4caml_sv_undef (value unit)
{
CAMLparam1 (unit);
/*CAMLreturn (Val_sv (newSV (0)));*/
CAMLreturn (Val_sv (&PL_sv_undef));
}
CAMLprim value
perl4caml_sv_is_undef (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
CAMLreturn (!SvPOK (sv) && !SvIOK (sv) && SvTYPE (sv) == SVt_NULL
? Val_true : Val_false);
}
CAMLprim value
perl4caml_sv_yes (value unit)
{
CAMLparam1 (unit);
CAMLreturn (Val_sv (&PL_sv_yes));
}
CAMLprim value
perl4caml_sv_no (value unit)
{
CAMLparam1 (unit);
CAMLreturn (Val_sv (&PL_sv_no));
}
static int
sv_type (SV *sv)
{
switch (SvTYPE (sv))
{
case SVt_IV: return 1;
case SVt_NV: return 2;
case SVt_PV: return 3;
case SVt_RV: return 4;
case SVt_PVAV: return 5;
case SVt_PVHV: return 6;
case SVt_PVCV: return 7;
case SVt_PVGV: return 8;
case SVt_PVMG: return 9;
default: return 0;
}
}
CAMLprim value
perl4caml_sv_type (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
CAMLreturn (Val_int (sv_type (sv)));
}
CAMLprim value
perl4caml_address_of_sv (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
CAMLreturn (caml_copy_nativeint ((long) sv));
}
CAMLprim value
perl4caml_address_of_av (value avv)
{
CAMLparam1 (avv);
AV *av = Av_val (avv);
CAMLreturn (caml_copy_nativeint ((long) av));
}
CAMLprim value
perl4caml_address_of_hv (value hvv)
{
CAMLparam1 (hvv);
HV *hv = Hv_val (hvv);
CAMLreturn (caml_copy_nativeint ((long) hv));
}
CAMLprim value
perl4caml_scalarref (value svv)
{
CAMLparam1 (svv);
CAMLlocal1 (rsvv);
SV *sv = Sv_val (svv);
rsvv = Val_sv (newRV_inc (sv));
CAMLreturn (rsvv);
}
CAMLprim value
perl4caml_arrayref (value avv)
{
CAMLparam1 (avv);
CAMLlocal1 (rsvv);
AV *av = Av_val (avv);
rsvv = Val_sv (newRV_inc ((SV *) av));
CAMLreturn (rsvv);
}
CAMLprim value
perl4caml_hashref (value hvv)
{
CAMLparam1 (hvv);
CAMLlocal1 (rsvv);
HV *hv = Hv_val (hvv);
rsvv = Val_sv (newRV_inc ((SV *) hv));
CAMLreturn (rsvv);
}
CAMLprim value
perl4caml_reftype (value svv)
{
CAMLparam1 (svv);
SV *sv = Sv_val (svv);
if (!SvROK (sv))
caml_invalid_argument ("reftype: SV is not a reference");
CAMLreturn (Val_int (sv_type (SvRV (sv))));
}
CAMLprim value
perl4caml_deref (value svv)
{
CAMLparam1 (svv);
CAMLlocal1 (rsvv);
SV *sv = Sv_val (svv);
if (!SvROK (sv))
caml_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:
caml_invalid_argument ("deref: SV is not a reference to a scalar");
}
sv = SvRV (sv);
/* Increment the reference count because we're creating another
* value pointing at the referenced SV.
*/
sv = SvREFCNT_inc (sv);
rsvv = Val_sv (sv);
CAMLreturn (rsvv);
}
CAMLprim value
perl4caml_deref_array (value svv)
{
CAMLparam1 (svv);
CAMLlocal1 (ravv);
SV *sv = Sv_val (svv);
if (!SvROK (sv))
caml_invalid_argument ("deref_array: SV is not a reference");
switch (SvTYPE (SvRV (sv))) {
case SVt_PVAV:
break;
default:
caml_invalid_argument ("deref_array: SV is not a reference to an array");
}
sv = SvRV (sv);
/* Increment the reference count because we're creating another
* value pointing at the referenced AV.
*/
sv = SvREFCNT_inc (sv);
ravv = Val_av ((AV *) sv);
CAMLreturn (ravv);
}
CAMLprim value
perl4caml_deref_hash (value svv)
{
CAMLparam1 (svv);
CAMLlocal1 (rhvv);
SV *sv = Sv_val (svv);
if (!SvROK (sv))
caml_invalid_argument ("deref_hash: SV is not a reference");
switch (SvTYPE (SvRV (sv))) {
case SVt_PVHV:
break;
default:
caml_invalid_argument ("deref_hash: SV is not a reference to a hash");
}
sv = SvRV (sv);
/* Increment the reference count because we're creating another
* value pointing at the referenced HV.
*/
sv = SvREFCNT_inc (sv);
rhvv = Val_hv ((HV *) sv);
CAMLreturn (rhvv);
}
CAMLprim value
perl4caml_av_empty (value unit)
{
CAMLparam1 (unit);
AV *av = newAV ();
CAMLreturn (Val_av (av));
}
/* We don't know in advance how long the list will be, which makes this
* a little harder.
*/
CAMLprim value
perl4caml_av_of_sv_list (value svlistv)
{
CAMLparam1 (svlistv);
CAMLlocal1 (svv);
SV *sv, **svlist = 0;
int alloc = 0, size = 0;
AV *av;
for (; svlistv != Val_int (0); svlistv = Field (svlistv, 1))
{
svv = Field (svlistv, 0);
sv = Sv_val (svv);
if (size >= alloc) {
alloc = alloc == 0 ? 1 : alloc * 2;
svlist = realloc (svlist, alloc * sizeof (SV *));
}
svlist[size++] = sv;
}
av = av_make (size, svlist);
if (alloc > 0) free (svlist); /* Free memory allocated to SV list. */
CAMLreturn (Val_av (av));
}
/* XXX av_map would be faster if we also had sv_list_of_av. */
CAMLprim value
perl4caml_av_push (value avv, value svv)
{
CAMLparam2 (avv, svv);
AV *av = Av_val (avv);
SV *sv = Sv_val (svv);
av_push (av, sv);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_av_pop (value avv)
{
CAMLparam1 (avv);
AV *av = Av_val (avv);
SV *sv = av_pop (av);
/* Increment the reference count because we're creating another
* value pointing at the referenced AV.
*/
sv = SvREFCNT_inc (sv);
CAMLreturn (Val_sv (sv));
}
CAMLprim value
perl4caml_av_unshift (value avv, value svv)
{
CAMLparam2 (avv, svv);
AV *av = Av_val (avv);
SV *sv = Sv_val (svv);
av_unshift (av, 1);
SvREFCNT_inc (sv);
if (av_store (av, 0, sv) == 0)
SvREFCNT_dec (sv);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_av_shift (value avv)
{
CAMLparam1 (avv);
AV *av = Av_val (avv);
SV *sv = av_shift (av);
/* Increment the reference count because we're creating another
* value pointing at the referenced AV.
*/
sv = SvREFCNT_inc (sv);
CAMLreturn (Val_sv (sv));
}
CAMLprim value
perl4caml_av_length (value avv)
{
CAMLparam1 (avv);
AV *av = Av_val (avv);
CAMLreturn (Val_int (av_len (av) + 1));
}
CAMLprim value
perl4caml_av_set (value avv, value i, value svv)
{
CAMLparam3 (avv, i, svv);
AV *av = Av_val (avv);
SV *sv = Sv_val (svv);
SvREFCNT_inc (sv);
if (av_store (av, Int_val (i), sv) == 0)
SvREFCNT_dec (sv);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_av_get (value avv, value i)
{
CAMLparam2 (avv, i);
AV *av = Av_val (avv);
SV **svp = av_fetch (av, Int_val (i), 0);
if (svp == 0) caml_invalid_argument ("av_get: index out of bounds");
/* Increment the reference count because we're creating another
* value pointing at the referenced AV.
*/
*svp = SvREFCNT_inc (*svp);
CAMLreturn (Val_sv (*svp));
}
CAMLprim value
perl4caml_av_clear (value avv)
{
CAMLparam1 (avv);
AV *av = Av_val (avv);
av_clear (av);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_av_undef (value avv)
{
CAMLparam1 (avv);
AV *av = Av_val (avv);
av_undef (av);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_av_extend (value avv, value i)
{
CAMLparam2 (avv, i);
AV *av = Av_val (avv);
av_extend (av, Int_val (i));
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_hv_empty (value unit)
{
CAMLparam1 (unit);
HV *hv = newHV ();
CAMLreturn (Val_hv (hv));
}
CAMLprim value
perl4caml_hv_set (value hvv, value key, value svv)
{
CAMLparam3 (hvv, key, svv);
HV *hv = Hv_val (hvv);
SV *sv = Sv_val (svv);
SvREFCNT_inc (sv);
if (hv_store (hv, String_val (key), caml_string_length (key), sv, 0) == 0)
SvREFCNT_dec (sv);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_hv_get (value hvv, value key)
{
CAMLparam2 (hvv, key);
HV *hv = Hv_val (hvv);
SV **svp = hv_fetch (hv, String_val (key), caml_string_length (key), 0);
if (svp == 0) caml_raise_not_found ();
/* Increment the reference count because we're creating another
* value pointing at the referenced SV.
*/
SvREFCNT_inc (*svp);
CAMLreturn (Val_sv (*svp));
}
CAMLprim value
perl4caml_hv_exists (value hvv, value key)
{
CAMLparam2 (hvv, key);
HV *hv = Hv_val (hvv);
bool r = hv_exists (hv, String_val (key), caml_string_length (key));
CAMLreturn (r ? Val_true : Val_false);
}
CAMLprim value
perl4caml_hv_delete (value hvv, value key)
{
CAMLparam2 (hvv, key);
HV *hv = Hv_val (hvv);
hv_delete (hv, String_val (key), caml_string_length (key), G_DISCARD);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_hv_clear (value hvv)
{
CAMLparam1 (hvv);
HV *hv = Hv_val (hvv);
hv_clear (hv);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_hv_undef (value hvv)
{
CAMLparam1 (hvv);
HV *hv = Hv_val (hvv);
hv_undef (hv);
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_hv_iterinit (value hvv)
{
CAMLparam1 (hvv);
HV *hv = Hv_val (hvv);
int i = hv_iterinit (hv);
CAMLreturn (caml_copy_int32 (i));
}
CAMLprim value
perl4caml_hv_iternext (value hvv)
{
CAMLparam1 (hvv);
CAMLlocal1 (hev);
HV *hv = Hv_val (hvv);
HE *he = hv_iternext (hv);
if (he == NULL) caml_raise_not_found ();
hev = Val_he (he);
CAMLreturn (hev);
}
CAMLprim value
perl4caml_hv_iterkey (value hev)
{
CAMLparam1 (hev);
CAMLlocal1 (strv);
HE *he = He_val (hev);
I32 len;
char *str = hv_iterkey (he, &len);
strv = caml_alloc_string (len);
memcpy (String_val (strv), str, len);
CAMLreturn (strv);
}
CAMLprim value
perl4caml_hv_iterval (value hvv, value hev)
{
CAMLparam2 (hvv, hev);
CAMLlocal1 (svv);
HV *hv = Hv_val (hvv);
HE *he = He_val (hev);
SV *sv = hv_iterval (hv, he);
SvREFCNT_inc (sv);
svv = Val_sv (sv);
CAMLreturn (svv);
}
CAMLprim value
perl4caml_hv_iternextsv (value hvv)
{
CAMLparam1 (hvv);
CAMLlocal3 (strv, svv, rv);
HV *hv = Hv_val (hvv);
char *str; I32 len;
SV *sv = hv_iternextsv (hv, &str, &len);
if (sv == NULL) caml_raise_not_found ();
SvREFCNT_inc (sv);
svv = Val_sv (sv);
strv = caml_alloc_string (len);
memcpy (String_val (strv), str, len);
/* Construct a tuple (strv, svv). */
rv = caml_alloc_tuple (2);
Field (rv, 0) = strv;
Field (rv, 1) = svv;
CAMLreturn (rv);
}
CAMLprim value
perl4caml_get_sv (value optcreate, value name)
{
CAMLparam2 (optcreate, name);
CAMLlocal1 (create);
SV *sv;
create = unoption (optcreate, Val_false);
sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE);
if (sv == NULL) caml_raise_not_found ();
/* Increment the reference count because we're creating another
* value pointing at the referenced SV.
*/
SvREFCNT_inc (sv);
CAMLreturn (Val_sv (sv));
}
CAMLprim value
perl4caml_get_av (value optcreate, value name)
{
CAMLparam2 (optcreate, name);
CAMLlocal1 (create);
AV *av;
create = unoption (optcreate, Val_false);
av = get_av (String_val (name), create == Val_true ? TRUE : FALSE);
if (av == NULL) caml_raise_not_found ();
/* Increment the reference count because we're creating another
* value pointing at the AV.
*/
SvREFCNT_inc (av);
CAMLreturn (Val_av (av));
}
CAMLprim value
perl4caml_get_hv (value optcreate, value name)
{
CAMLparam2 (optcreate, name);
CAMLlocal1 (create);
HV *hv;
create = unoption (optcreate, Val_false);
hv = get_hv (String_val (name), create == Val_true ? TRUE : FALSE);
if (hv == NULL) caml_raise_not_found ();
/* Increment the reference count because we're creating another
* value pointing at the HV.
*/
SvREFCNT_inc (hv);
CAMLreturn (Val_hv (hv));
}
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 = caml_copy_string (err);
caml_raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv);
}
}
CAMLprim value
perl4caml_call (value optsv, value optfnname, value arglist)
{
CAMLparam3 (optsv, optfnname, arglist);
dSP;
int count;
SV *sv;
CAMLlocal3 (errv, svv, fnname);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
if (optsv != Val_int (0))
{
svv = unoption (optsv, Val_false);
sv = Sv_val (svv);
count = call_sv (sv, G_EVAL|G_SCALAR);
}
else if (optfnname != Val_int (0))
{
fnname = unoption (optfnname, Val_false);
count = call_pv (String_val (fnname), G_EVAL|G_SCALAR);
}
else
{
fprintf (stderr,
"Perl.call: must supply either 'sv' or 'fn' parameters.");
abort ();
}
SPAGAIN;
assert (count == 1); /* Pretty sure it should never be anything else. */
/* Pop return value off the stack. Note that the return value on the
* stack is mortal, so we need to take a copy.
*/
sv = newSVsv (POPs);
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
svv = Val_sv (sv);
CAMLreturn (svv);
}
CAMLprim value
perl4caml_call_array (value optsv, value optfnname, value arglist)
{
CAMLparam3 (optsv, optfnname, arglist);
dSP;
int i, count;
SV *sv;
CAMLlocal5 (errv, svv, fnname, list, cons);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
if (optsv != Val_int (0))
{
svv = unoption (optsv, Val_false);
sv = Sv_val (svv);
count = call_sv (sv, G_EVAL|G_ARRAY);
}
else if (optfnname != Val_int (0))
{
fnname = unoption (optfnname, Val_false);
count = call_pv (String_val (fnname), G_EVAL|G_ARRAY);
}
else
{
fprintf (stderr,
"Perl.call_array: must supply either 'sv' or 'fn' parameters.");
abort ();
}
SPAGAIN;
/* Pop all the return values off the stack into a list. Values on the
* stack are mortal, so we must copy them.
*/
list = Val_int (0);
for (i = 0; i < count; ++i) {
SV *sv;
cons = caml_alloc (2, 0);
Field (cons, 1) = list;
list = cons;
sv = newSVsv (POPs);
Field (cons, 0) = Val_sv (sv);
}
/* Restore the stack. */
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
CAMLreturn (list);
}
CAMLprim value
perl4caml_call_void (value optsv, value optfnname, value arglist)
{
CAMLparam3 (optsv, optfnname, arglist);
dSP;
int count;
SV *sv;
CAMLlocal3 (errv, svv, fnname);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
if (optsv != Val_int (0))
{
svv = unoption (optsv, Val_false);
sv = Sv_val (svv);
count = call_sv (sv, G_EVAL|G_VOID);
}
else if (optfnname != Val_int (0))
{
fnname = unoption (optfnname, Val_false);
count = call_pv (String_val (fnname), G_EVAL|G_VOID|G_DISCARD);
}
else
{
fprintf (stderr,
"Perl.call_void: must supply either 'sv' or 'fn' parameters.");
abort ();
}
SPAGAIN;
assert (count == 0);
/* Restore the stack. */
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_eval (value expr)
{
CAMLparam1 (expr);
dSP;
SV *sv;
CAMLlocal2 (errv, svv);
sv = eval_pv (String_val (expr), G_SCALAR);
check_perl_failure ();
svv = Val_sv (sv);
CAMLreturn (svv);
}
CAMLprim value
perl4caml_call_method (value ref, value name, value arglist)
{
CAMLparam3 (ref, name, arglist);
dSP;
int count;
SV *sv;
CAMLlocal2 (errv, svv);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
sv = Sv_val (ref);
XPUSHs (sv_2mortal (newSVsv (sv)));
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
count = call_method (String_val (name), G_EVAL|G_SCALAR);
SPAGAIN;
assert (count == 1); /* Pretty sure it should never be anything else. */
/* Pop return value off the stack. Note that the return value on the
* stack is mortal, so we need to take a copy.
*/
sv = newSVsv (POPs);
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
svv = Val_sv (sv);
CAMLreturn (svv);
}
CAMLprim value
perl4caml_call_method_array (value ref, value name, value arglist)
{
CAMLparam3 (ref, name, arglist);
dSP;
int count, i;
SV *sv;
CAMLlocal4 (errv, svv, list, cons);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
sv = Sv_val (ref);
XPUSHs (sv_2mortal (newSVsv (sv)));
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
count = call_method (String_val (name), G_EVAL|G_ARRAY);
SPAGAIN;
/* Pop all return values off the stack. Note that the return values on the
* stack are mortal, so we need to take a copy.
*/
list = Val_int (0);
for (i = 0; i < count; ++i) {
SV *sv;
cons = caml_alloc (2, 0);
Field (cons, 1) = list;
list = cons;
sv = newSVsv (POPs);
Field (cons, 0) = Val_sv (sv);
}
/* Restore the stack. */
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
CAMLreturn (list);
}
CAMLprim value
perl4caml_call_method_void (value ref, value name, value arglist)
{
CAMLparam3 (ref, name, arglist);
dSP;
int count;
SV *sv;
CAMLlocal2 (errv, svv);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
sv = Sv_val (ref);
XPUSHs (sv_2mortal (newSVsv (sv)));
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
SPAGAIN;
assert (count == 0);
/* Restore the stack. */
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
CAMLreturn (Val_unit);
}
CAMLprim value
perl4caml_call_class_method (value classname, value name, value arglist)
{
CAMLparam3 (classname, name, arglist);
dSP;
int count;
SV *sv;
CAMLlocal2 (errv, svv);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
count = call_method (String_val (name), G_EVAL|G_SCALAR);
SPAGAIN;
assert (count == 1); /* Pretty sure it should never be anything else. */
/* Pop return value off the stack. Note that the return value on the
* stack is mortal, so we need to take a copy.
*/
sv = newSVsv (POPs);
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
svv = Val_sv (sv);
CAMLreturn (svv);
}
CAMLprim value
perl4caml_call_class_method_array (value classname, value name, value arglist)
{
CAMLparam3 (classname, name, arglist);
dSP;
int count, i;
SV *sv;
CAMLlocal4 (errv, svv, list, cons);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
count = call_method (String_val (name), G_EVAL|G_ARRAY);
SPAGAIN;
/* Pop all return values off the stack. Note that the return values on the
* stack are mortal, so we need to take a copy.
*/
list = Val_int (0);
for (i = 0; i < count; ++i) {
cons = caml_alloc (2, 0);
Field (cons, 1) = list;
list = cons;
Field (cons, 0) = Val_sv (newSVsv (POPs));
}
/* Restore the stack. */
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
CAMLreturn (list);
}
CAMLprim value
perl4caml_call_class_method_void (value classname, value name, value arglist)
{
CAMLparam3 (classname, name, arglist);
dSP;
int count;
SV *sv;
CAMLlocal2 (errv, svv);
ENTER;
SAVETMPS;
/* Push the parameter list. */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSVpv (String_val (classname), 0)));
/* Iteration over the linked list. */
for (; arglist != Val_int (0); arglist = Field (arglist, 1))
{
svv = Field (arglist, 0);
sv = Sv_val (svv);
XPUSHs (sv_2mortal (newSVsv (sv)));
}
PUTBACK;
count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD);
SPAGAIN;
assert (count == 0);
/* Restore the stack. */
PUTBACK;
FREETMPS;
LEAVE;
check_perl_failure ();
CAMLreturn (Val_unit);
}
static value
Val_voidptr (void *ptr)
{
CAMLparam0 ();
CAMLlocal1 (rv);
rv = caml_alloc (1, Abstract_tag);
Field(rv, 0) = (value) ptr;
CAMLreturn (rv);
}
#if PERL4CAML_REFCOUNTING_EXPERIMENTAL
static void
xv_finalize (value v)
{
/*fprintf (stderr, "about to decrement %p\n", Xv_val (v));*/
SvREFCNT_dec ((SV *) Xv_val (v));
}
static struct custom_operations xv_custom_operations = {
"xv_custom_operations",
xv_finalize,
custom_compare_default,
custom_hash_default,
custom_serialize_default,
custom_deserialize_default
};
static value
Val_xv (SV *sv)
{
CAMLparam0 ();
CAMLlocal1 (rv);
rv = caml_alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1);
Xv_val (rv) = sv;
CAMLreturn (rv);
}
#endif /* PERL4CAML_REFCOUNTING_EXPERIMENTAL */
static value
unoption (value option, value deflt)
{
if (option == Val_int (0)) /* "None" */
return deflt;
else /* "Some 'a" */
return Field (option, 0);
}
perl4caml-0.9.5/perl.ml 0000644 0000764 0000764 00000015422 10762251735 014312 0 ustar rjones rjones (* Interface to Perl from OCaml.
Copyright (C) 2003 Merjis Ltd.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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 GNU
Library General Public License for more details.
You should have received a copy of the GNU General Public License
along with this library; see the file COPYING. If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.
$Id: perl.ml,v 1.16 2008-03-01 13:02:21 rich Exp $
*)
type sv
type av
type hv
exception Perl_failure of string
(* Initialization. This must happen first, otherwise other parts of the
* program will segfault because of a missing interpreter.
*)
external c_init : unit -> unit = "perl4caml_init"
let () =
Callback.register_exception "perl4caml_perl_failure" (Perl_failure "");
c_init (); (* Initialise C code. *)
()
external int_of_sv : sv -> int = "perl4caml_int_of_sv"
external sv_of_int : int -> sv = "perl4caml_sv_of_int"
external float_of_sv : sv -> float = "perl4caml_float_of_sv"
external sv_of_float : float -> sv = "perl4caml_sv_of_float"
external string_of_sv : sv -> string = "perl4caml_string_of_sv"
external sv_of_string : string -> sv = "perl4caml_sv_of_string"
external sv_is_true : sv -> bool = "perl4caml_sv_is_true"
external sv_undef : unit -> sv = "perl4caml_sv_undef"
external sv_is_undef : sv -> bool = "perl4caml_sv_is_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 string_of_sv_t = function
SVt_NULL -> "SVt_NULL"
| SVt_IV -> "SVt_IV"
| SVt_NV -> "SVt_NV"
| SVt_PV -> "SVt_PV"
| SVt_RV -> "SVt_RV"
| SVt_PVAV -> "SVt_PVAV"
| SVt_PVHV -> "SVt_PVHV"
| SVt_PVCV -> "SVt_PVCV"
| SVt_PVGV -> "SVt_PVGV"
| SVt_PVMG -> "SVt_PVMG"
external reftype : sv -> sv_t = "perl4caml_reftype"
external address_of_sv : sv -> Nativeint.t = "perl4caml_address_of_sv"
external address_of_av : av -> Nativeint.t = "perl4caml_address_of_av"
external address_of_hv : hv -> Nativeint.t = "perl4caml_address_of_hv"
external scalarref : sv -> sv = "perl4caml_scalarref"
external arrayref : av -> sv = "perl4caml_arrayref"
external hashref : hv -> sv = "perl4caml_hashref"
external deref : sv -> sv = "perl4caml_deref"
external deref_array : sv -> av = "perl4caml_deref_array"
external deref_hash : sv -> hv = "perl4caml_deref_hash"
external av_empty : unit -> av = "perl4caml_av_empty"
external av_of_sv_list : sv list -> av = "perl4caml_av_of_sv_list"
external av_push : av -> sv -> unit = "perl4caml_av_push"
external av_pop : av -> sv = "perl4caml_av_pop"
external av_shift : av -> sv = "perl4caml_av_shift"
external av_unshift : av -> sv -> unit = "perl4caml_av_unshift"
external av_length : av -> int = "perl4caml_av_length"
external av_set : av -> int -> sv -> unit = "perl4caml_av_set"
external av_get : av -> int -> sv = "perl4caml_av_get"
external av_clear : av -> unit = "perl4caml_av_clear"
external av_undef : av -> unit = "perl4caml_av_undef"
external av_extend : av -> int -> unit = "perl4caml_av_extend"
let av_map f av =
let list = ref [] in
for i = 0 to av_length av - 1 do
list := f (av_get av i) :: !list
done;
List.rev !list
let list_of_av av =
let list = ref [] in
for i = 0 to av_length av - 1 do
list := av_get av i :: !list
done;
List.rev !list
let av_of_string_list strs =
av_of_sv_list (List.map sv_of_string strs)
external hv_empty : unit -> hv = "perl4caml_hv_empty"
external hv_set : hv -> string -> sv -> unit = "perl4caml_hv_set"
external hv_get : hv -> string -> sv = "perl4caml_hv_get"
external hv_exists : hv -> string -> bool = "perl4caml_hv_exists"
external hv_delete : hv -> string -> unit = "perl4caml_hv_delete"
external hv_clear : hv -> unit = "perl4caml_hv_clear"
external hv_undef : hv -> unit = "perl4caml_hv_undef"
type he
external hv_iterinit : hv -> Int32.t = "perl4caml_hv_iterinit"
external hv_iternext : hv -> he = "perl4caml_hv_iternext"
external hv_iterkey : he -> string = "perl4caml_hv_iterkey"
external hv_iterval : hv -> he -> sv = "perl4caml_hv_iterval"
external hv_iternextsv : hv -> string * sv = "perl4caml_hv_iternextsv"
let hv_of_assoc xs =
let hv = hv_empty () in
List.iter (fun (k, v) -> hv_set hv k v) xs;
hv
let assoc_of_hv hv =
ignore (hv_iterinit hv);
(* Someone please rewrite this to make it tail-rec! - Rich. XXX *)
let rec loop acc =
try
let k, v = hv_iternextsv hv in
loop ((k, v) :: acc)
with
Not_found -> acc
in
loop []
let hv_keys hv =
ignore (hv_iterinit hv);
(* Someone please rewrite this to make it tail-rec! - Rich. XXX *)
let rec loop acc =
try
let he = hv_iternext hv in
let k = hv_iterkey he in
loop (k :: acc)
with
Not_found -> acc
in
loop []
let hv_values hv =
ignore (hv_iterinit hv);
(* Someone please rewrite this to make it tail-rec! - Rich. XXX *)
let rec loop acc =
try
let he = hv_iternext hv in
let v = hv_iterval hv he in
loop (v :: acc)
with
Not_found -> acc
in
loop []
external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv"
external get_av : ?create:bool -> string -> av = "perl4caml_get_av"
external get_hv : ?create:bool -> string -> hv = "perl4caml_get_hv"
external call : ?sv:sv -> ?fn:string -> sv list -> sv
= "perl4caml_call"
external call_array : ?sv:sv -> ?fn:string -> sv list -> sv list
= "perl4caml_call_array"
external call_void : ?sv:sv -> ?fn:string -> sv list -> unit
= "perl4caml_call_void"
external eval : string -> sv
= "perl4caml_eval"
external call_method : sv -> string -> sv list -> sv
= "perl4caml_call_method"
external call_method_array : sv -> string -> sv list -> sv list
= "perl4caml_call_method_array"
external call_method_void : sv -> string -> sv list -> unit
= "perl4caml_call_method_void"
external call_class_method : string -> string -> sv list -> sv
= "perl4caml_call_class_method"
external call_class_method_array : string -> string -> sv list -> sv list
= "perl4caml_call_class_method_array"
external call_class_method_void : string -> string -> sv list -> unit
= "perl4caml_call_class_method_void"
perl4caml-0.9.5/Makefile.config 0000644 0000764 0000764 00000004542 10762251735 015723 0 ustar rjones rjones # perl4caml configuration -*- Makefile -*-
# Copyright (C) 2003 Merjis Ltd.
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this library; see the file COPYING. If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
# $Id: Makefile.config,v 1.27 2008-03-01 13:02:21 rich Exp $
# PERLINCDIR
# Directory containing the Perl include files, eg. .
PERLINCDIR := $(shell perl -MConfig -e 'print "$$Config{archlib}/CORE"')
# OCAMLLIBDIR
# This is where we will install perl4caml (actually in the /perl subdirectory
# of this, so you will need to add '-I +perl' when compiling programs).
OCAMLLIBDIR := $(shell ocamlc -where)
# EXTRA_CFLAGS
# You can specify extra flags to be passed to gcc here.
#
# One flag you might want to pass here is
#
# -DPERL4CAML_REFCOUNTING_EXPERIMENTAL=1
#
# which will turn on experimental support for reference counting.
# Without this none of the Perl structures that you allocate will get
# freed. With this we try to map Perl's reference counting onto
# OCaml's garbage collection by using finalizers. Although the
# feature is marked "EXPERIMENTAL", I have fixed most of the bugs
# and it's now turned on by default.
#EXTRA_CFLAGS :=
EXTRA_CFLAGS := -DPERL4CAML_REFCOUNTING_EXPERIMENTAL=1
#EXTRA_CFLAGS := -I/Users/rich/OCaml/lib/ocaml/std-lib
#EXTRA_CFLAGS := -g
# DYNALOADER_HACK
# XXX Hack required by ocamlopt, and sometimes ocamlc.
# To work out what this should be, try:
# `perl -MExtUtils::Embed -e ldopts'
DYNALOADER_HACK := $(shell perl -MExtUtils::Embed -e ldopts | egrep -o '/[^[:space:]]*DynaLoader.a')
#DYNALOADER_HACK := /usr/lib/perl/5.8/auto/DynaLoader/DynaLoader.a
#DYNALOADER_HACK := /System/Library/Perl/5.8.1/darwin-thread-multi-2level/auto/DynaLoader/DynaLoader.a
# PACKAGE and VERSION
PACKAGE := perl4caml
VERSION := 0.9.5
perl4caml-0.9.5/Makefile 0000644 0000764 0000764 00000013553 10762251735 014461 0 ustar rjones rjones # Interface to Perl from OCaml.
# Copyright (C) 2003 Merjis Ltd.
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this library; see the file COPYING. If not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
#
# $Id: Makefile,v 1.33 2008-03-01 13:02:21 rich Exp $
include Makefile.config
OCAMLC := ocamlc
OCAMLOPT := ocamlopt
OCAMLMKLIB := ocamlmklib
OCAMLDEP := ocamldep
OCAMLDOC := ocamldoc
OCAMLCINCS := -I wrappers
OCAMLOPTINCS := $(OCAMLCINCS)
OCAMLCFLAGS := -w s -g $(OCAMLCINCS)
OCAMLOPTFLAGS := -w s $(OCAMLOPTINCS)
PERLCFLAGS := $(shell perl -e 'use Config; print $$Config{ccflags};')
CC := gcc
CFLAGS := -fPIC -Wall -Wno-unused \
-I$(OCAMLLIBDIR) \
-I$(PERLINCDIR) $(PERLCFLAGS) \
$(EXTRA_CFLAGS) $(EXTRA_EXTRA_CFLAGS)
LIBPERL := $(shell perl -MExtUtils::Embed -e ldopts)
SED := sed
OCAMLDOCFLAGS := -html -stars -sort $(OCAMLCINCS)
WRAPPERS := \
wrappers/pl_Data_Dumper.cmo \
wrappers/pl_Date_Calc.cmo \
wrappers/pl_Date_Format.cmo \
wrappers/pl_Date_Parse.cmo \
wrappers/pl_Net_Google_Cache.cmo \
wrappers/pl_Net_Google_Response.cmo \
wrappers/pl_Net_Google_Search.cmo \
wrappers/pl_Net_Google_Spelling.cmo \
wrappers/pl_Net_Google.cmo \
wrappers/pl_HTML_Element.cmo \
wrappers/pl_HTML_Parser.cmo \
wrappers/pl_HTML_TreeBuilder.cmo \
wrappers/pl_URI.cmo \
wrappers/pl_HTTP_Cookies.cmo \
wrappers/pl_HTTP_Headers.cmo \
wrappers/pl_HTTP_Message.cmo \
wrappers/pl_HTTP_Request.cmo \
wrappers/pl_HTTP_Request_Common.cmo \
wrappers/pl_HTTP_Response.cmo \
wrappers/pl_HTML_Form.cmo \
wrappers/pl_LWP_UserAgent.cmo \
wrappers/pl_Template.cmo \
wrappers/pl_WWW_Mechanize.cmo
all: perl4caml.cma perl4caml.cmxa META all-examples html
perl4caml.cma: perl.cmo perl_c.o $(WRAPPERS)
$(OCAMLMKLIB) -o perl4caml $(LIBPERL) $^
perl4caml.cmxa: perl.cmx perl_c.o $(WRAPPERS:.cmo=.cmx)
$(OCAMLMKLIB) -o perl4caml $(LIBPERL) $^
all-examples: examples/test.bc examples/loadpage.bc examples/google.bc \
examples/test.opt examples/loadpage.opt examples/google.opt \
examples/parsedate.bc examples/parsedate.opt
TEST_PROGRAMS := $(patsubst %.ml,%.bc,$(wildcard test/*.ml)) \
$(patsubst %.ml,%.opt,$(wildcard test/*.ml))
test: $(TEST_PROGRAMS) run-tests
check: test
run-tests:
@fails=0; count=0; \
export LD_LIBRARY_PATH=`pwd`:$$LD_LIBRARY_PATH; \
for prog in $(TEST_PROGRAMS); do \
if ! $$prog; then \
echo Test $$prog failed; \
fails=$$(($$fails+1)); \
fi; \
count=$$(($$count+1)); \
done; \
if [ $$fails -eq 0 ]; then \
echo All tests succeeded.; \
exit 0; \
else \
echo $$fails/$$count tests failed.; \
exit 1; \
fi
%.bc: %.cmo
$(OCAMLC) $(OCAMLCFLAGS) perl4caml.cma $^ -o $@
%.opt: %.cmx
$(OCAMLOPT) $(OCAMLOPTFLAGS) -cclib -L. perl4caml.cmxa \
$(DYNALOADER_HACK) $^ -o $@
%.cmi: %.mli
$(OCAMLC) $(OCAMLCFLAGS) -c $<
%.cmo: %.ml
$(OCAMLC) $(OCAMLCFLAGS) -c $<
%.cmx: %.ml
$(OCAMLOPT) $(OCAMLOPTFLAGS) -c $<
.SUFFIXES: .mli .ml .cmi .cmo .cmx
META: META.in Makefile.config
$(SED) -e 's/@PACKAGE@/$(PACKAGE)/' \
-e 's/@VERSION@/$(VERSION)/' \
< $< > $@
# Clean.
JUNKFILES = core *~ *.bak *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so \
*.bc *.opt
clean:
rm -f META
for d in . examples test wrappers; do \
(cd $$d; rm -f $(JUNKFILES)); \
done
# Build dependencies.
ifeq ($(wildcard .depend),.depend)
include .depend
endif
depend: .depend
.depend: $(wildcard *.ml) $(wildcard *.mli) $(wildcard examples/*.ml) \
$(wildcard wrappers/*.ml)
$(OCAMLDEP) $(OCAMLCINCS) *.mli *.ml examples/*.ml wrappers/*.ml \
> .depend
# Install.
install:
rm -rf $(DESTDIR)$(OCAMLLIBDIR)/perl
install -c -m 0755 -d $(DESTDIR)$(OCAMLLIBDIR)/perl
install -c -m 0755 -d $(DESTDIR)$(OCAMLLIBDIR)/stublibs
install -c -m 0644 perl.cmi perl.mli perl4caml.cma perl4caml.cmxa \
perl4caml.a libperl4caml.a META \
$(WRAPPERS:.cmo=.ml) $(WRAPPERS:.cmo=.cmi) \
$(DESTDIR)$(OCAMLLIBDIR)/perl
install -c -m 0644 dllperl4caml.so $(DESTDIR)$(OCAMLLIBDIR)/stublibs
# Distribution.
dist:
$(MAKE) check-manifest
rm -rf $(PACKAGE)-$(VERSION)
mkdir $(PACKAGE)-$(VERSION)
tar -cf - -T MANIFEST | tar -C $(PACKAGE)-$(VERSION) -xf -
tar zcf $(PACKAGE)-$(VERSION).tar.gz $(PACKAGE)-$(VERSION)
rm -rf $(PACKAGE)-$(VERSION)
ls -l $(PACKAGE)-$(VERSION).tar.gz
check-manifest:
@for d in `find -type d -name CVS | grep -v '^\./debian/'`; \
do \
b=`dirname $$d`/; \
awk -F/ '$$1 != "D" {print $$2}' $$d/Entries | \
sed -e "s|^|$$b|" -e "s|^\./||"; \
done | sort > .check-manifest; \
sort MANIFEST > .orig-manifest; \
diff -u .orig-manifest .check-manifest; rv=$$?; \
rm -f .orig-manifest .check-manifest; \
exit $$rv
# Debian packages.
dpkg:
@if [ 0 != `cvs -q update | wc -l` ]; then \
echo Please commit all changes to CVS first.; \
exit 1; \
fi
$(MAKE) dist
rm -rf /tmp/dbuild
mkdir /tmp/dbuild
cp $(PACKAGE)-$(VERSION).tar.gz \
/tmp/dbuild/$(PACKAGE)_$(VERSION).orig.tar.gz
export CVSROOT=`cat CVS/Root`; \
cd /tmp/dbuild && \
cvs export \
-d $(PACKAGE)-$(VERSION) \
-D now merjis/test/perl4caml
cd /tmp/dbuild/$(PACKAGE)-$(VERSION) && dpkg-buildpackage -rfakeroot
rm -rf /tmp/dbuild/$(PACKAGE)-$(VERSION)
ls -l /tmp/dbuild
# Documentation.
html: html/index.html
html/index.html: $(wildcard *.ml) $(wildcard *.mli) $(wildcard wrappers/*.ml)
rm -rf html
mkdir html
-$(OCAMLDOC) $(OCAMLDOCFLAGS) -d html $^
.PHONY: depend dist check-manifest html dpkg test run-tests perl4caml-0.9.5/AUTHORS 0000644 0000764 0000764 00000000316 10330373424 014051 0 ustar rjones rjones Richard W.M. Jones (rich@annexia.org)
- Main developer.
Olivier Andrieu
- Helped me to work around OCaml initialization bug.
Dave Benjamin (dave at 3dex dot com)
- Implemented Template Toolkit wrapper. perl4caml-0.9.5/examples/ 0000775 0000764 0000764 00000000000 10762251536 014631 5 ustar rjones rjones perl4caml-0.9.5/examples/.cvsignore 0000644 0000764 0000764 00000000051 10330373422 016611 0 ustar rjones rjones *.cmi
*.cmo
*.cmx
*.cma
*.cmxa
*.bc
*.opt perl4caml-0.9.5/examples/test.ml 0000644 0000764 0000764 00000003652 10330373422 016134 0 ustar rjones rjones (* Simple test of the API.
* Copyright (C) 2003 Merjis Ltd.
* $Id: test.ml,v 1.7 2004/11/25 22:16:17 rich Exp $
*)
open Printf
let () =
(* Perform a full collection - good way to find bugs in initialization code*)
Gc.full_major ();
(* Load "test.pl". *)
Perl.eval "require 'examples/test.pl'";
(* Call some subroutines in [test.pl]. *)
let sv = Perl.call ~fn:"return_one" [] in
printf "return_one returned %d\n" (Perl.int_of_sv sv); flush stdout;
let sv = Perl.call ~fn:"adder" [Perl.sv_of_int 3; Perl.sv_of_int 4] in
printf "adder (3, 4) = %d\n" (Perl.int_of_sv sv); flush stdout;
let svlist = Perl.call_array ~fn:"return_array" [] in
print_string "array returned:";
List.iter (
fun sv ->
printf " %d" (Perl.int_of_sv sv);
) svlist;
printf "\n"; flush stdout;
let sv = Perl.sv_of_string "return_one" in
let sv = Perl.call ~sv [] in
printf "return_one returned %d\n" (Perl.int_of_sv sv); flush stdout;
(* Call a Perl closure. *)
let sv = Perl.call ~fn:"return_closure" [] in
let sv = Perl.call ~sv [Perl.sv_of_int 3; Perl.sv_of_int 4] in
printf "closure returned %d\n" (Perl.int_of_sv sv); flush stdout;
(* Evaluate a simple expression. *)
Perl.eval "$a = 3";
printf "$a contains %d\n" (Perl.int_of_sv (Perl.get_sv "a")); flush stdout;
(* Test calling methods in the "TestClass" class. *)
let obj = Perl.call_class_method "TestClass" "new" [] in
let sv = Perl.call_method obj "get_foo" [] in
printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout;
Perl.call_method obj "set_foo" [Perl.sv_of_int 2];
let sv = Perl.call_method obj "get_foo" [] in
printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout;
(* Create an undef value and test it. *)
let undef = Perl.sv_undef () in
printf "sv_is_undef (undef) = %s\n"
(string_of_bool (Perl.sv_is_undef undef));
(* Perform a full collection - good way to find GC/allocation bugs. *)
Gc.full_major ()
perl4caml-0.9.5/examples/parsedate.ml 0000644 0000764 0000764 00000001333 10330373422 017117 0 ustar rjones rjones (* Example program which uses Date::Parse.
* Copyright (C) 2003 Merjis Ltd.
* $Id: parsedate.ml,v 1.2 2003/12/11 17:41:52 rich Exp $
*)
open Printf
open Pl_Date_Parse
open Pl_Date_Format
let () =
(* Parse dates passed on the command line. *)
if Array.length Sys.argv <= 1 then
eprintf "parsedate [list of quoted date strings ...]\n"
else (
let strings = List.tl (Array.to_list Sys.argv) in
List.iter (fun s ->
printf "input string = '%s' ->\n" s;
let t = str2time s in
printf "\ttime_t = %f\n" t;
let s = ctime t in
printf "\tconverted back to string = %s\n" s;
printf "\n"
) strings
);
(* Perform a full collection - good way to find GC/allocation bugs. *)
Gc.full_major ()
perl4caml-0.9.5/examples/google.ml 0000644 0000764 0000764 00000001601 10330373422 016421 0 ustar rjones rjones (* Example program which uses Net::Google to query Google.
* You will need to have a Google API key in ~/.googlekey for this to work.
* Copyright (C) 2003 Merjis Ltd.
* $Id: google.ml,v 1.4 2003/12/11 17:41:52 rich Exp $
*)
open Printf
open Pl_Net_Google
let () =
(* Load Google API key. *)
let home = Sys.getenv "HOME" in
let chan = open_in (home ^ "/.googlekey") in
let key = input_line chan in
close_in chan;
(* Create the Google query object. *)
let google = Pl_Net_Google.new_ ~key () in
(* Search. *)
let search = google#search () in
search#set_query "merjis";
search#set_max_results 5;
printf "Top 5 results for \"merjis\":\n"; flush stdout;
List.iter
(fun response ->
printf "* %s\n \n\n" response#title response#url
) search#results;
(* Perform a full collection - good way to find GC/allocation bugs. *)
Gc.full_major ()
perl4caml-0.9.5/examples/test.pl 0000644 0000764 0000764 00000000744 10330373422 016136 0 ustar rjones rjones use lib "examples";
use TestClass;
print "this is loading the 'test.pl' script!\n";
sub return_one
{
print "this is the 'return_one' function!\n";
1
}
sub return_array
{
print "this is the 'return_array' function!\n";
(1, 2, 3)
}
sub return_closure
{
sub { $_[0] * $_[1] }
}
sub dies
{
print "this is the 'dies' function! about to die now ...\n";
die "this is the exception message from 'dies'";
}
sub adder
{
$_[0] + $_[1]
}
perl4caml-0.9.5/examples/TestClass.pm 0000644 0000764 0000764 00000000415 10330373422 017060 0 ustar rjones rjones package TestClass;
sub new
{
my $class = shift;
my $self = { foo => 1 };
bless $self, $class;
}
sub get_foo
{
my $self = shift;
$self->{foo}
}
sub set_foo
{
my $self = shift;
my $value = shift;
$self->{foo} = $value
}
1;
perl4caml-0.9.5/examples/loadpage.ml 0000644 0000764 0000764 00000003046 10330373422 016726 0 ustar rjones rjones (* 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.5 2003/12/11 17:41:52 rich Exp $
*)
open Printf
open Pl_LWP_UserAgent
open Pl_HTTP_Request
open Pl_HTML_TreeBuilder
open Pl_HTML_Element
let () =
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;
(* Perform a full collection - good way to find GC/allocation bugs. *)
Gc.full_major ()