#
# this is all hacky etc. it works so it's gonna stay for now. it is not and
# should not be installed.
#
# $Id$
#
package MakeHelper;
use strict;
use warnings;
use IO::File;
use File::Spec;
our $autogen_dir = '.';
# --------------------------------------------------------------------------- #
# copied/borrowed from Gtk2-Perl's CodeGen
sub write_boot
{
my %opts = (
ignore => '^[^:]+$', # ignore package with no colons in it
filename => File::Spec->catdir ($autogen_dir,
'cairo-perl-boot.xsh'),
'glob' => File::Spec->catfile ('xs', '*.xs'),
@_,
);
my $ignore = $opts{ignore};
my $file = IO::File->new (">$opts{filename}")
or die "Cannot write $opts{filename}: $!";
print $file "\n\n/* This file is automatically generated, any changes made here will be lost! */\n\n";
my %boot=();
my @xs_files = 'ARRAY' eq ref $opts{xs_files}
? @{ $opts{xs_files} }
: glob $opts{'glob'};
foreach my $xsfile (@xs_files) {
my $in = IO::File->new ($xsfile)
or die "can't open $xsfile: $!\n";
while (<$in>) {
next unless m/^MODULE\s*=\s*(\S+)/;
#warn "found $1 in $&\n";
my $package = $1;
next if $package =~ m/$ignore/;
$package =~ s/:/_/g;
my $sym = "boot_$package";
print $file "CAIRO_PERL_CALL_BOOT ($sym);\n"
unless $boot{$sym};
$boot{$sym}++;
}
close $in;
}
close $file;
}
# --------------------------------------------------------------------------- #
sub name
{
$_[0] =~ /cairo_(\w+)_t/;
return $1;
}
sub do_typemaps
{
my %objects = %{shift ()};
my %structs = %{shift ()};
my %enums = %{shift ()};
my %flags = %{shift ()};
my %object_guards = %{shift ()};
my %struct_guards = %{shift ()};
my %enum_guards = %{shift ()};
my %flag_guards = %{shift ()};
my $cairo_perl = File::Spec->catfile ($autogen_dir,
'cairo-perl-auto.typemap');
open TYPEMAP, '>', $cairo_perl
or die "unable to open ($cairo_perl) for output";
print TYPEMAP <<EOS;
#
# This file was automatically generated. Do not edit.
#
TYPEMAP
EOS
sub type_id
{
my $ret = shift;
$ret =~ s/ \*//;
uc ($ret);
}
sub func_name
{
$_[0] =~ /cairo_(\w+)_t/;
$1;
}
foreach (keys %objects, keys %structs, keys %enums, keys %flags)
{
print TYPEMAP "$_\tT_CAIROPERL_GENERIC_WRAPPER\n";
}
foreach (keys %objects, keys %structs)
{
my $trunk = $_;
$trunk =~ s/ \*//;
print TYPEMAP "const $_\tT_CAIROPERL_GENERIC_WRAPPER\n";
print TYPEMAP "${trunk}_ornull *\tT_CAIROPERL_GENERIC_WRAPPER\n";
print TYPEMAP "const ${trunk}_ornull *\tT_CAIROPERL_GENERIC_WRAPPER\n";
}
foreach (keys %objects)
{
my $trunk = $_;
$trunk =~ s/ \*//;
print TYPEMAP "${trunk}_noinc *\tT_CAIROPERL_GENERIC_WRAPPER\n";
}
my $conversion_code = ';
(my $ntype = $type) =~ s/(?:const\s+)?([:\w]+)(?:\s*\*)$/$1/x;
my $result = $type;
if ($ntype =~ m/(.+)_t(_.+)?/) {
my ($name, $options) = ($1, $2);
$name =~ s/([^_]+)/ucfirst $1/ge;
$name =~ s/_//g;
$result = $name . $options;
}
\$result';
print TYPEMAP <<"EOS";
INPUT
T_CAIROPERL_GENERIC_WRAPPER
\$var = Sv\${$conversion_code} (\$arg);
OUTPUT
T_CAIROPERL_GENERIC_WRAPPER
\$arg = newSV\${$conversion_code} (\$var);
EOS
close TYPEMAP;
# ------------------------------------------------------------------- #
my $header = File::Spec->catfile ($autogen_dir,
'cairo-perl-auto.h');
open HEADER, '>', $header
or die "unable to open ($header) for output";
print HEADER <<EOS;
/*
* This file was automatically generated. Do not edit.
*/
#include <cairo.h>
EOS
sub mangle
{
my $mangled = shift;
$mangled =~ s/_t$//;
$mangled =~ s/([^_]+)/ucfirst $1/ge;
$mangled =~ s/_//g;
return $mangled;
}
sub reference
{
my $ref = shift;
$ref =~ s/_t$//;
$ref .= '_reference';
return $ref;
}
# ------------------------------------------------------------------- #
print HEADER "\n/* objects */\n\n";
foreach (keys %objects)
{
/^(.+) \*/;
my $type = $1;
my $mangled = mangle ($type);
my $ref = reference ($type);
if (exists $object_guards{$type}) {
print HEADER "$object_guards{$type}\n";
}
print HEADER <<"EOS";
typedef $type ${type}_noinc;
typedef $type ${type}_ornull;
#define Sv$mangled(sv) (($type *) cairo_object_from_sv (sv, "$objects{$_}"))
#define Sv${mangled}_ornull(sv) (((sv) && SvOK (sv)) ? Sv$mangled(sv) : NULL)
#define newSV$mangled(object) (cairo_object_to_sv (($type *) $ref (object), "$objects{$_}"))
#define newSV${mangled}_noinc(object) (cairo_object_to_sv (($type *) object, "$objects{$_}"))
#define newSV${mangled}_ornull(object) (((object) == NULL) ? &PL_sv_undef : newSV$mangled(object))
EOS
if (exists $object_guards{$type}) {
print HEADER "#endif /* $object_guards{$type} */\n";
}
}
# ------------------------------------------------------------------- #
print HEADER "\n/* structs */\n\n";
foreach (keys %structs)
{
/^(.+) \*/;
my $type = $1;
my $mangled = mangle ($type);
if (exists $struct_guards{$type}) {
print HEADER "$struct_guards{$type}\n";
}
print HEADER <<"EOS";
typedef $type ${type}_ornull;
#define Sv$mangled(sv) (($type *) cairo_struct_from_sv (sv, "$structs{$_}"))
#define Sv${mangled}_ornull(sv) (((sv) && SvOK (sv)) ? Sv$mangled(sv) : NULL)
#define newSV$mangled(struct_) (cairo_struct_to_sv (($type *) struct_, "$structs{$_}"))
#define newSV${mangled}_ornull(struct_) (((struct_) == NULL) ? &PL_sv_undef : newSV$mangled(struct_))
EOS
if (exists $struct_guards{$type}) {
print HEADER "#endif /* $struct_guards{$type} */\n";
}
}
# ------------------------------------------------------------------- #
print HEADER "\n/* enums */\n\n";
foreach my $type (keys %enums)
{
my $mangled = mangle ($type);
my $name = name ($type);
next unless @{$enums{$type}};
if (exists $enum_guards{$type}) {
print HEADER "$enum_guards{$type}\n";
}
print HEADER <<"EOS";
$type cairo_${name}_from_sv (SV * $name);
SV * cairo_${name}_to_sv ($type val);
#define Sv$mangled(sv) (cairo_${name}_from_sv (sv))
#define newSV$mangled(val) (cairo_${name}_to_sv (val))
EOS
if (exists $enum_guards{$type}) {
print HEADER "#endif /* $enum_guards{$type} */\n";
}
}
# ------------------------------------------------------------------- #
print HEADER "\n/* flags */\n\n";
foreach my $type (keys %flags)
{
my $mangled = mangle ($type);
my $name = name ($type);
next unless @{$flags{$type}};
if (exists $flag_guards{$type}) {
print HEADER "$flag_guards{$type}\n";
}
print HEADER <<"EOS";
$type cairo_${name}_from_sv (SV * $name);
SV * cairo_${name}_to_sv ($type val);
#define Sv$mangled(sv) (cairo_${name}_from_sv (sv))
#define newSV$mangled(val) (cairo_${name}_to_sv (val))
EOS
if (exists $flag_guards{$type}) {
print HEADER "#endif /* $flag_guards{$type} */\n";
}
}
close HEADER;
return ($cairo_perl);
}
# --------------------------------------------------------------------------- #
sub canonicalize_enum_name
{
my ($name, $prefix) = @_;
$name =~ s/$prefix//;
$name =~ tr/_/-/;
$name = lc ($name);
return $name;
}
sub enum_if_tree_from
{
my ($prefix, @enums) = @_;
my $str = '';
my $is_first = 1;
foreach my $full (@enums)
{
my $name = canonicalize_enum_name($full, $prefix);
# +1 so that strncmp also looks at the trailing \0, and
# discerns 'color' and 'color-alpha', for example.
my $len = length ($name) + 1;
my $conditional = $is_first ? 'if' : 'else if';
$str .= <<"EOS";
$conditional (strncmp (str, "$name", $len) == 0)
return $full;
EOS
$is_first = 0;
}
return $str;
}
sub enum_if_tree_to
{
my ($prefix, @enums) = @_;
my $str = '';
my $is_first = 1;
foreach my $full (@enums)
{
my $name = canonicalize_enum_name($full, $prefix);
my $conditional = $is_first ? 'if' : 'else if';
$str .= <<"EOS";
$conditional (val == $full)
return newSVpv ("$name", 0);
EOS
$is_first = 0;
}
return $str;
}
sub do_enums
{
my %enums = %{shift ()};
my %guards = %{shift ()};
my $cairo_enums = 'cairo-perl-enums.c';
open ENUMS, '>', $cairo_enums
or die "unable to open ($cairo_enums) for output";
print ENUMS <<'EOS';
/*
* This file was automatically generated. Do not edit.
*/
#include <cairo-perl.h>
EOS
foreach my $type (keys %enums)
{
my $name = name($type);
my @enum_values = @{$enums{$type}};
next unless @enum_values;
my $value_list =
join ", ", map {
canonicalize_enum_name($_, $enum_values[0])
} @enum_values[1..$#enum_values];
my $tree_from = enum_if_tree_from (@enum_values);
my $tree_to = enum_if_tree_to (@enum_values);
if (exists $guards{$type}) {
print ENUMS "$guards{$type}\n\n";
}
print ENUMS <<"EOS";
$type
cairo_${name}_from_sv (SV * $name)
{
char * str = SvPV_nolen ($name);
$tree_from
croak ("`%s' is not a valid $type value; valid values are: $value_list", str);
return 0;
}
SV *
cairo_${name}_to_sv ($type val)
{
$tree_to
warn ("unknown $type value %d encountered", val);
return &PL_sv_undef;
}
EOS
if (exists $guards{$type}) {
print ENUMS "#endif /* $guards{$type} */\n";
}
}
close ENUMS;
}
# --------------------------------------------------------------------------- #
sub flag_if_tree_from
{
my ($prefix, @flags) = @_;
my $str = '';
my $is_first = 1;
foreach my $full (@flags)
{
my $name = canonicalize_enum_name($full, $prefix);
# +1 so that strncmp also looks at the trailing \0, and
# discerns 'color' and 'color-alpha', for example.
my $len = length ($name) + 1;
my $conditional = $is_first ? 'if' : 'else if';
$str .= <<"EOS";
$conditional (strncmp (str, "$name", $len) == 0) {
return $full;
}
EOS
$is_first = 0;
}
return $str;
}
sub flag_if_tree_to
{
my ($prefix, @flags) = @_;
my $str = '';
foreach my $full (@flags)
{
my $name = canonicalize_enum_name($full, $prefix);
$str .= <<"EOS";
if ((val & $full) == $full) {
val -= $full;
av_push (flags, newSVpv ("$name", 0));
}
EOS
}
return $str;
}
sub do_flags
{
my %flags = %{shift ()};
my %guards = %{shift ()};
my $cairo_flags = 'cairo-perl-flags.c';
open FLAGS, '>', $cairo_flags
or die "unable to open ($cairo_flags) for output";
print FLAGS <<'EOS';
/*
* This file was automatically generated. Do not edit.
*/
#include <cairo-perl.h>
#include <cairo-perl-private.h>
EOS
foreach my $type (keys %flags)
{
my $name = name($type);
my @flag_values = @{$flags{$type}};
next unless @flag_values;
my $value_list =
join ", ", map {
canonicalize_enum_name($_, $flag_values[0])
} @flag_values[1..$#flag_values];
my $tree_from = flag_if_tree_from (@flag_values);
my $tree_to = flag_if_tree_to (@flag_values);
if (exists $guards{$type}) {
print FLAGS "$guards{$type}\n\n";
}
print FLAGS <<"EOS";
static $type
cairo_${name}_from_sv_part (const char *str)
{
$tree_from
croak ("`%s' is not a valid $type value; valid values are: $value_list", str);
return 0;
}
$type
cairo_${name}_from_sv (SV * $name)
{
if (cairo_perl_sv_is_array_ref ($name)) {
AV *vals = (AV *) SvRV ($name);
$type value = 0;
int i;
for (i=0; i<=av_len(vals); i++)
value |= cairo_${name}_from_sv_part (
SvPV_nolen (*av_fetch (vals, i, 0)));
return value;
}
if (SvPOK ($name))
return cairo_${name}_from_sv_part (SvPV_nolen ($name));
croak ("`%s' is not a valid $type value, expecting a string scalar "
"or an arrayref of strings",
SvPV_nolen ($name));
return 0;
}
SV *
cairo_${name}_to_sv ($type val)
{
AV *flags = newAV ();
$tree_to
return newRV_noinc ((SV *) flags);
}
EOS
if (exists $guards{$type}) {
print FLAGS "#endif /* $guards{$type} */\n";
}
}
close FLAGS;
}
1;