1082 lines
29 KiB
Perl
1082 lines
29 KiB
Perl
# PIKA - Photo and Image Kooker Application
|
|
# Copyright (C) 1998-2003 Manish Singh <yosh@gimp.org>
|
|
|
|
# This program is free software: you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
package Pika::CodeGen::app;
|
|
|
|
$destdir = "$main::destdir/app/pdb";
|
|
$builddir = "$main::builddir/app/pdb";
|
|
|
|
*arg_types = \%Pika::CodeGen::pdb::arg_types;
|
|
*arg_parse = \&Pika::CodeGen::pdb::arg_parse;
|
|
|
|
*enums = \%Pika::CodeGen::enums::enums;
|
|
|
|
*write_file = \&Pika::CodeGen::util::write_file;
|
|
*FILE_EXT = \$Pika::CodeGen::util::FILE_EXT;
|
|
|
|
use Text::Wrap qw(wrap);
|
|
|
|
sub quotewrap {
|
|
my ($str, $indent, $subsequent_indent) = @_;
|
|
my $leading = ' ' x $indent . '"';
|
|
my $subsequent_leading = ' ' x $subsequent_indent . '"';
|
|
$Text::Wrap::columns = 1000;
|
|
$Text::Wrap::unexpand = 0;
|
|
$str = wrap($leading, $subsequent_leading, $str);
|
|
$str =~ s/^\s*//s;
|
|
$str =~ s/(.)\n(.)/$1\\n"\n$2/g;
|
|
$str =~ s/(.)$/$1"/s;
|
|
$str;
|
|
}
|
|
|
|
sub format_code_frag {
|
|
my ($code, $indent) = @_;
|
|
|
|
chomp $code;
|
|
$code =~ s/\t/' ' x 8/eg;
|
|
|
|
if (!$indent && $code =~ /^\s*{\s*\n.*\n\s*}\s*$/s) {
|
|
$code =~ s/^\s*{\s*\n//s;
|
|
$code =~ s/\n\s*}\s*$//s;
|
|
}
|
|
else {
|
|
$code =~ s/^/' ' x ($indent ? 4 : 2)/meg;
|
|
}
|
|
$code .= "\n";
|
|
|
|
$code =~ s/^\s+$//mg;
|
|
|
|
$code;
|
|
}
|
|
|
|
sub declare_args {
|
|
my $proc = shift;
|
|
my $out = shift;
|
|
my $outargs = shift;
|
|
|
|
local $result = "";
|
|
|
|
foreach (@_) {
|
|
my @args = @{$proc->{$_}} if (defined $proc->{$_});
|
|
|
|
foreach (@args) {
|
|
my ($type, $name) = &arg_parse($_->{type});
|
|
my $arg = $arg_types{$type};
|
|
|
|
if ($arg->{array} && !exists $_->{array}) {
|
|
warn "Array without number of elements param in $proc->{name}";
|
|
}
|
|
|
|
unless (exists $_->{no_declare} || exists $_->{dead}) {
|
|
if ($outargs) {
|
|
if (exists $arg->{app_type}) {
|
|
$result .= " $arg->{app_type}$_->{name} = $arg->{init_value}";
|
|
}
|
|
else {
|
|
$result .= " $arg->{type}$_->{name} = $arg->{init_value}";
|
|
}
|
|
}
|
|
else {
|
|
if (exists $arg->{app_const_type}) {
|
|
$result .= " $arg->{app_const_type}$_->{name}";
|
|
}
|
|
else {
|
|
$result .= " $arg->{const_type}$_->{name}";
|
|
}
|
|
}
|
|
$result .= ";\n";
|
|
|
|
if (exists $arg->{headers}) {
|
|
foreach (@{$arg->{headers}}) {
|
|
$out->{headers}->{$_}++;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
$result;
|
|
}
|
|
|
|
sub marshal_inargs {
|
|
my ($proc, $argc) = @_;
|
|
|
|
my $result = "";
|
|
my %decls;
|
|
|
|
my @inargs = @{$proc->{inargs}} if (defined $proc->{inargs});
|
|
|
|
foreach (@inargs) {
|
|
my($pdbtype, @typeinfo) = &arg_parse($_->{type});
|
|
my $arg = $arg_types{$pdbtype};
|
|
my $var = $_->{name};
|
|
my $value;
|
|
|
|
$value = "pika_value_array_index (args, $argc)";
|
|
if (!exists $_->{dead}) {
|
|
$result .= eval qq/" $arg->{get_value_func};\n"/;
|
|
}
|
|
|
|
$argc++;
|
|
|
|
if (!exists $_->{no_validate}) {
|
|
$success = 1;
|
|
}
|
|
}
|
|
|
|
$result = "\n" . $result . "\n" if $result;
|
|
$result;
|
|
}
|
|
|
|
sub marshal_outargs {
|
|
my $proc = shift;
|
|
my $result;
|
|
my $argc = 0;
|
|
my @outargs = @{$proc->{outargs}} if (defined $proc->{outargs});
|
|
|
|
if ($success) {
|
|
$result = <<CODE;
|
|
return_vals = pika_procedure_get_return_values (procedure, success,
|
|
error ? *error : NULL);
|
|
CODE
|
|
} else {
|
|
$result = <<CODE;
|
|
return_vals = pika_procedure_get_return_values (procedure, TRUE, NULL);
|
|
CODE
|
|
}
|
|
|
|
if (scalar @outargs) {
|
|
my $outargs = "";
|
|
|
|
foreach (@{$proc->{outargs}}) {
|
|
my ($pdbtype) = &arg_parse($_->{type});
|
|
my $arg = $arg_types{$pdbtype};
|
|
my $var = $_->{name};
|
|
my $var_len;
|
|
my $value;
|
|
|
|
$argc++;
|
|
|
|
$value = "pika_value_array_index (return_vals, $argc)";
|
|
|
|
if (exists $_->{array}) {
|
|
my $arrayarg = $_->{array};
|
|
|
|
if (exists $arrayarg->{name}) {
|
|
$var_len = $arrayarg->{name};
|
|
}
|
|
else {
|
|
$var_len = 'num_' . $_->{name};
|
|
}
|
|
}
|
|
|
|
$outargs .= eval qq/" $arg->{take_value_func};\n"/;
|
|
}
|
|
|
|
$outargs =~ s/^/' ' x 2/meg if $success;
|
|
$outargs =~ s/^/' ' x 2/meg if $success && $argc > 1;
|
|
|
|
$result .= "\n" if $success || $argc > 1;
|
|
$result .= ' ' x 2 . "if (success)\n" if $success;
|
|
$result .= ' ' x 4 . "{\n" if $success && $argc > 1;
|
|
$result .= $outargs;
|
|
$result .= ' ' x 4 . "}\n" if $success && $argc > 1;
|
|
$result .= "\n" . ' ' x 2 . "return return_vals;\n";
|
|
}
|
|
else {
|
|
if ($success) {
|
|
$result =~ s/return_vals =/return/;
|
|
$result =~ s/ error/error/;
|
|
}
|
|
else {
|
|
$result =~ s/ return_vals =/\n return/;
|
|
$result =~ s/ error/error/;
|
|
}
|
|
}
|
|
|
|
$result;
|
|
}
|
|
|
|
sub generate_pspec {
|
|
my $arg = shift;
|
|
my ($pdbtype, @typeinfo) = &arg_parse($arg->{type});
|
|
my $name = $arg->{canonical_name};
|
|
my $nick = $arg->{canonical_name};
|
|
my $blurb = exists $arg->{desc} ? $arg->{desc} : "";
|
|
my $min;
|
|
my $max;
|
|
my $default;
|
|
my $flags = 'PIKA_PARAM_READWRITE';
|
|
my $pspec = "";
|
|
my $postproc = "";
|
|
|
|
$nick =~ s/-/ /g;
|
|
|
|
if (exists $arg->{no_validate}) {
|
|
$flags .= ' | PIKA_PARAM_NO_VALIDATE';
|
|
}
|
|
|
|
if ($pdbtype eq 'image') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_image ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'resource') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_resource ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'brush') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_brush ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'font') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_font ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'gradient') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_gradient ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'palette') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_palette ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'pattern') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_pattern ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'item') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_item ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'drawable') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_drawable ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'text_layer') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_text_layer ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'layer') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_layer ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'channel') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_channel ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'layer_mask') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_layer_mask ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'selection') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_selection ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'vectors') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_vectors ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'display') {
|
|
$none_ok = exists $arg->{none_ok} ? 'TRUE' : 'FALSE';
|
|
$pspec = <<CODE;
|
|
pika_param_spec_display ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$none_ok,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'file') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_object ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
G_TYPE_FILE,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'tattoo') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_uint ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
1, G_MAXUINT32, 1,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'guide') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_uint ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
1, G_MAXUINT32, 1,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'sample_point') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_uint ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
1, G_MAXUINT32, 1,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'float') {
|
|
$min = defined $typeinfo[0] ? $typeinfo[0] : -G_MAXDOUBLE;
|
|
$max = defined $typeinfo[2] ? $typeinfo[2] : G_MAXDOUBLE;
|
|
$default = exists $arg->{default} ? $arg->{default} : defined $typeinfo[0] ? $typeinfo[0] : 0.0;
|
|
$pspec = <<CODE;
|
|
g_param_spec_double ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$min, $max, $default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'int32') {
|
|
if (defined $typeinfo[0]) {
|
|
$min = ($typeinfo[1] eq '<') ? ($typeinfo[0] + 1) : $typeinfo[0];
|
|
}
|
|
else {
|
|
$min = G_MININT32;
|
|
}
|
|
if (defined $typeinfo[2]) {
|
|
$max = ($typeinfo[3] eq '<') ? ($typeinfo[2] - 1) : $typeinfo[2];
|
|
}
|
|
else {
|
|
$max = G_MAXINT32;
|
|
}
|
|
$default = exists $arg->{default} ? $arg->{default} : defined $typeinfo[0] ? $typeinfo[0] : 0;
|
|
$pspec = <<CODE;
|
|
g_param_spec_int ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$min, $max, $default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'int16') {
|
|
if (defined $typeinfo[0]) {
|
|
$min = ($typeinfo[1] eq '<') ? ($typeinfo[0] + 1) : $typeinfo[0];
|
|
}
|
|
else {
|
|
$min = G_MININT16;
|
|
}
|
|
if (defined $typeinfo[2]) {
|
|
$max = ($typeinfo[3] eq '<') ? ($typeinfo[2] - 1) : $typeinfo[2];
|
|
}
|
|
else {
|
|
$max = G_MAXINT16;
|
|
}
|
|
$default = exists $arg->{default} ? $arg->{default} : defined $typeinfo[0] ? $typeinfo[0] : 0;
|
|
$pspec = <<CODE;
|
|
g_param_spec_int ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$min, $max, $default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'uchar') {
|
|
if (defined $typeinfo[0]) {
|
|
$min = ($typeinfo[1] eq '<') ? ($typeinfo[0] + 1) : $typeinfo[0];
|
|
}
|
|
else {
|
|
$min = 0;
|
|
}
|
|
if (defined $typeinfo[2]) {
|
|
$max = ($typeinfo[3] eq '<') ? ($typeinfo[2] - 1) : $typeinfo[2];
|
|
}
|
|
else {
|
|
$max = G_MAXUINT8;
|
|
}
|
|
$default = exists $arg->{default} ? $arg->{default} : defined $typeinfo[0] ? $typeinfo[0] : 0;
|
|
$pspec = <<CODE;
|
|
g_param_spec_uchar ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$min, $max, $default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'boolean') {
|
|
$default = exists $arg->{default} ? $arg->{default} : FALSE;
|
|
$pspec = <<CODE;
|
|
g_param_spec_boolean ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'string') {
|
|
$allow_non_utf8 = exists $arg->{allow_non_utf8} ? 'TRUE' : 'FALSE';
|
|
$null_ok = exists $arg->{null_ok} ? 'TRUE' : 'FALSE';
|
|
$non_empty = exists $arg->{non_empty} ? 'TRUE' : 'FALSE';
|
|
$default = exists $arg->{default} ? $arg->{default} : NULL;
|
|
$pspec = <<CODE;
|
|
pika_param_spec_string ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$allow_non_utf8, $null_ok, $non_empty,
|
|
$default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'enum') {
|
|
$enum_type = $typeinfo[0];
|
|
$enum_type =~ s/([a-z])([A-Z])/$1_$2/g;
|
|
$enum_type =~ s/([A-Z]+)([A-Z])/$1_$2/g;
|
|
$enum_type =~ tr/[a-z]/[A-Z]/;
|
|
$enum_type =~ s/^PIKA/PIKA_TYPE/;
|
|
$enum_type =~ s/^GEGL/GEGL_TYPE/;
|
|
$default = exists $arg->{default} ? $arg->{default} : $enums{$typeinfo[0]}->{symbols}[0];
|
|
|
|
my ($foo, $bar, @remove) = &arg_parse($arg->{type});
|
|
|
|
foreach (@remove) {
|
|
$postproc .= 'pika_param_spec_enum_exclude_value (PIKA_PARAM_SPEC_ENUM ($pspec),';
|
|
$postproc .= "\n $_);\n";
|
|
}
|
|
|
|
if ($postproc eq '') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_enum ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$enum_type,
|
|
$default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
else {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_enum ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$enum_type,
|
|
$default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
}
|
|
elsif ($pdbtype eq 'unit') {
|
|
$typeinfo[0] = 'PIKA_UNIT_PIXEL' unless defined $typeinfo[0];
|
|
$allow_pixels = $typeinfo[0] eq 'PIKA_UNIT_PIXEL' ? TRUE : FALSE;
|
|
$allow_percent = exists $arg->{allow_percent} ? TRUE : FALSE;
|
|
$default = exists $arg->{default} ? $arg->{default} : $typeinfo[0];
|
|
$pspec = <<CODE;
|
|
pika_param_spec_unit ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$allow_pixels,
|
|
$allow_percent,
|
|
$default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'color') {
|
|
$has_alpha = exists $arg->{has_alpha} ? TRUE : FALSE;
|
|
$default = exists $arg->{default} ? $arg->{default} : NULL;
|
|
$pspec = <<CODE;
|
|
pika_param_spec_rgb ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$has_alpha,
|
|
$default,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'parasite') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_parasite ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'param') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_param ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
G_TYPE_PARAM,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'int32array') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_int32_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'floatarray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_float_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'bytes') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_boxed ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
G_TYPE_BYTES,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'strv') {
|
|
$pspec = <<CODE;
|
|
g_param_spec_boxed ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
G_TYPE_STRV,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'colorarray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_rgb_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'imagearray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_object_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
PIKA_TYPE_IMAGE,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'itemarray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_object_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
PIKA_TYPE_ITEM,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'layerarray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_object_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
PIKA_TYPE_LAYER,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'channelarray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_object_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
PIKA_TYPE_CHANNEL,
|
|
$flags)
|
|
CODE
|
|
}
|
|
elsif ($pdbtype eq 'vectorarray') {
|
|
$pspec = <<CODE;
|
|
pika_param_spec_object_array ("$name",
|
|
"$nick",
|
|
"$blurb",
|
|
PIKA_TYPE_VECTORS,
|
|
$flags)
|
|
CODE
|
|
}
|
|
else {
|
|
warn "Unsupported PDB type: $arg->{name} ($arg->{type})";
|
|
exit -1;
|
|
}
|
|
|
|
$pspec =~ s/\s$//;
|
|
|
|
return ($pspec, $postproc);
|
|
}
|
|
|
|
sub canonicalize {
|
|
$_ = shift; s/_/-/g; return $_;
|
|
}
|
|
|
|
sub generate {
|
|
my @procs = @{(shift)};
|
|
my %out;
|
|
my $total = 0.0;
|
|
my $argc;
|
|
|
|
foreach $name (@procs) {
|
|
my $proc = $main::pdb{$name};
|
|
my $out = \%{$out{$proc->{group}}};
|
|
|
|
my @inargs = @{$proc->{inargs}} if (defined $proc->{inargs});
|
|
my @outargs = @{$proc->{outargs}} if (defined $proc->{outargs});
|
|
|
|
my $blurb = $proc->{blurb};
|
|
my $help = $proc->{help};
|
|
|
|
my $procedure_name;
|
|
|
|
local $success = 0;
|
|
|
|
if ($proc->{deprecated}) {
|
|
if ($proc->{deprecated} eq 'NONE') {
|
|
if (!$blurb) {
|
|
$blurb = "Deprecated: There is no replacement for this procedure.";
|
|
}
|
|
if ($help) {
|
|
$help .= "\n\n";
|
|
}
|
|
$help .= "Deprecated: There is no replacement for this procedure.";
|
|
}
|
|
else {
|
|
if (!$blurb) {
|
|
$blurb = "Deprecated: Use '$proc->{deprecated}' instead.";
|
|
}
|
|
if ($help) {
|
|
$help .= "\n\n";
|
|
}
|
|
$help .= "Deprecated: Use '$proc->{deprecated}' instead.";
|
|
}
|
|
}
|
|
|
|
$help =~ s/pika(\w+)\(\s*\)/"'pika".canonicalize($1)."'"/ge;
|
|
|
|
if ($proc->{group} eq "plug_in_compat") {
|
|
$procedure_name = "$proc->{canonical_name}";
|
|
} else {
|
|
$procedure_name = "pika-$proc->{canonical_name}";
|
|
}
|
|
|
|
$out->{pcount}++; $total++;
|
|
|
|
$out->{register} .= <<CODE;
|
|
|
|
/*
|
|
* pika-$proc->{canonical_name}
|
|
*/
|
|
procedure = pika_procedure_new (${name}_invoker);
|
|
pika_object_set_static_name (PIKA_OBJECT (procedure),
|
|
"$procedure_name");
|
|
pika_procedure_set_static_help (procedure,
|
|
@{[ "ewrap($blurb, 2, 34) ]},
|
|
@{[ "ewrap($help, 2, 34) ]},
|
|
NULL);
|
|
pika_procedure_set_static_attribution (procedure,
|
|
"$proc->{author}",
|
|
"$proc->{copyright}",
|
|
"$proc->{date}");
|
|
CODE
|
|
|
|
if ($proc->{deprecated}) {
|
|
$out->{register} .= <<CODE;
|
|
pika_procedure_set_deprecated (procedure,
|
|
"\"$proc->{deprecated}\"");
|
|
CODE
|
|
}
|
|
|
|
$argc = 0;
|
|
|
|
foreach $arg (@inargs) {
|
|
my ($pspec, $postproc) = &generate_pspec($arg);
|
|
|
|
$pspec =~ s/^/' ' x length(" pika_procedure_add_argument (")/meg;
|
|
|
|
$out->{register} .= <<CODE;
|
|
pika_procedure_add_argument (procedure,
|
|
${pspec});
|
|
CODE
|
|
|
|
if ($postproc ne '') {
|
|
$pspec = "procedure->args[$argc]";
|
|
$postproc =~ s/^/' '/meg;
|
|
$out->{register} .= eval qq/"$postproc"/;
|
|
}
|
|
|
|
$argc++;
|
|
}
|
|
|
|
$argc = 0;
|
|
|
|
foreach $arg (@outargs) {
|
|
my ($pspec, $postproc) = &generate_pspec($arg);
|
|
my $argc = 0;
|
|
|
|
$pspec =~ s/^/' ' x length(" pika_procedure_add_return_value (")/meg;
|
|
|
|
$out->{register} .= <<CODE;
|
|
pika_procedure_add_return_value (procedure,
|
|
${pspec});
|
|
CODE
|
|
|
|
if ($postproc ne '') {
|
|
$pspec = "procedure->values[$argc]";
|
|
$postproc =~ s/^/' '/meg;
|
|
$out->{register} .= eval qq/"$postproc"/;
|
|
}
|
|
|
|
$argc++;
|
|
}
|
|
|
|
$out->{register} .= <<CODE;
|
|
pika_pdb_register_procedure (pdb, procedure);
|
|
g_object_unref (procedure);
|
|
CODE
|
|
|
|
if (exists $proc->{invoke}->{headers}) {
|
|
foreach $header (@{$proc->{invoke}->{headers}}) {
|
|
$out->{headers}->{$header}++;
|
|
}
|
|
}
|
|
|
|
$out->{code} .= "\nstatic PikaValueArray *\n";
|
|
$out->{code} .= "${name}_invoker (PikaProcedure *procedure,\n";
|
|
$out->{code} .= ' ' x length($name) . " Pika *pika,\n";
|
|
$out->{code} .= ' ' x length($name) . " PikaContext *context,\n";
|
|
$out->{code} .= ' ' x length($name) . " PikaProgress *progress,\n";
|
|
$out->{code} .= ' ' x length($name) . " const PikaValueArray *args,\n";
|
|
$out->{code} .= ' ' x length($name) . " GError **error)\n{\n";
|
|
|
|
my $code = "";
|
|
|
|
if (exists $proc->{invoke}->{no_marshalling}) {
|
|
$code .= &format_code_frag($proc->{invoke}->{code}, 0) . "}\n";
|
|
}
|
|
else {
|
|
my $invoker = "";
|
|
|
|
$invoker .= ' ' x 2 . "PikaValueArray *return_vals;\n" if scalar @outargs;
|
|
$invoker .= &declare_args($proc, $out, 0, qw(inargs));
|
|
$invoker .= &declare_args($proc, $out, 1, qw(outargs));
|
|
|
|
$invoker .= &marshal_inargs($proc, 0);
|
|
$invoker .= "\n" if $invoker && $invoker !~ /\n\n/s;
|
|
|
|
my $frag = "";
|
|
|
|
if (exists $proc->{invoke}->{code}) {
|
|
$frag = &format_code_frag($proc->{invoke}->{code}, $success);
|
|
$frag = ' ' x 2 . "if (success)\n" . $frag if $success;
|
|
$success = ($frag =~ /success =/) unless $success;
|
|
}
|
|
|
|
chomp $invoker if !$frag;
|
|
$code .= $invoker . $frag;
|
|
$code .= "\n" if $frag =~ /\n\n/s || $invoker;
|
|
$code .= &marshal_outargs($proc) . "}\n";
|
|
}
|
|
|
|
if ($success) {
|
|
$out->{code} .= ' ' x 2 . "gboolean success";
|
|
unless ($proc->{invoke}->{success} eq 'NONE') {
|
|
$out->{code} .= " = $proc->{invoke}->{success}";
|
|
}
|
|
$out->{code} .= ";\n";
|
|
}
|
|
|
|
$out->{code} .= $code;
|
|
}
|
|
|
|
my $gpl = <<'GPL';
|
|
/* PIKA - Photo and Image Kooker Application
|
|
* a rebranding of The GNU Image Manipulation Program (created with heckimp)
|
|
* A derived work which may be trivial. However, any changes may be (C)2023 by Aldercone Studio
|
|
*
|
|
* Original copyright, applying to most contents (license remains unchanged):
|
|
* Copyright (C) 1995-2003 Spencer Kimball and Peter Mattis
|
|
*
|
|
* This program is free software: you can redistribute it and/or modify
|
|
* it under the terms of the GNU General Public License as published by
|
|
* the Free Software Foundation; either version 3 of the License, or
|
|
* (at your option) any later version.
|
|
*
|
|
* This program is distributed in the hope that it will be useful,
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
* GNU General Public License for more details.
|
|
*
|
|
* You should have received a copy of the GNU General Public License
|
|
* along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
*/
|
|
|
|
/* NOTE: This file is auto-generated by pdbgen.pl. */
|
|
|
|
GPL
|
|
|
|
my $group_procs = "";
|
|
my $longest = 0;
|
|
my $once = 0;
|
|
my $pcount = 0.0;
|
|
|
|
foreach $group (@main::groups) {
|
|
my $out = $out{$group};
|
|
|
|
foreach (@{$main::grp{$group}->{headers}}) { $out->{headers}->{$_}++ }
|
|
|
|
$out->{headers}->{"\"core/pikaparamspecs.h\""}++;
|
|
|
|
my @headers = sort {
|
|
my ($x, $y) = ($a, $b);
|
|
foreach ($x, $y) {
|
|
if (/^</) {
|
|
s/^</!/;
|
|
}
|
|
elsif (!/libpika/) {
|
|
s/^/~/;
|
|
}
|
|
}
|
|
$x cmp $y;
|
|
} keys %{$out->{headers}};
|
|
|
|
my $headers = "";
|
|
my $lib = 0;
|
|
my $seen = 0;
|
|
my $sys = 0;
|
|
my $base = 0;
|
|
my $error = 0;
|
|
my $utils = 0;
|
|
my $context = 0;
|
|
my $intl = 0;
|
|
|
|
foreach (@headers) {
|
|
$seen++ if /^</;
|
|
|
|
if ($sys == 0 && !/^</) {
|
|
$sys = 1;
|
|
$headers .= "\n" if $seen;
|
|
$headers .= "#include <gegl.h>\n\n";
|
|
$headers .= "#include <gdk-pixbuf/gdk-pixbuf.h>\n\n";
|
|
}
|
|
|
|
$seen = 0 if !/^</;
|
|
|
|
if (/libpika/) {
|
|
$lib = 1;
|
|
}
|
|
else {
|
|
$headers .= "\n" if $lib;
|
|
$lib = 0;
|
|
|
|
if ($sys == 1 && $base == 0) {
|
|
$base = 1;
|
|
$headers .= "#include \"libpikabase/pikabase.h\"\n\n";
|
|
$headers .= "#include \"pdb-types.h\"\n\n";
|
|
}
|
|
}
|
|
|
|
if (/pika-intl/) {
|
|
$intl = 1;
|
|
}
|
|
elsif (/pikapdb-utils/) {
|
|
$utils = 1;
|
|
}
|
|
elsif (/pikapdberror/) {
|
|
$error = 1;
|
|
}
|
|
elsif (/pikapdbcontext/) {
|
|
$context = 1;
|
|
}
|
|
else {
|
|
$headers .= "#include $_\n";
|
|
}
|
|
}
|
|
|
|
$headers .= "\n";
|
|
$headers .= "#include \"pikapdb.h\"\n";
|
|
$headers .= "#include \"pikapdberror.h\"\n" if $error;
|
|
$headers .= "#include \"pikapdb-utils.h\"\n" if $utils;
|
|
$headers .= "#include \"pikapdbcontext.h\"\n" if $context;
|
|
$headers .= "#include \"pikaprocedure.h\"\n";
|
|
$headers .= "#include \"internal-procs.h\"\n";
|
|
|
|
$headers .= "\n#include \"pika-intl.h\"\n" if $intl;
|
|
|
|
my $extra = {};
|
|
if (exists $main::grp{$group}->{extra}->{app}) {
|
|
$extra = $main::grp{$group}->{extra}->{app}
|
|
}
|
|
|
|
my $cfile = "$builddir/".canonicalize(${group})."-cmds.c$FILE_EXT";
|
|
open CFILE, "> $cfile" or die "Can't open $cfile: $!\n";
|
|
print CFILE $gpl;
|
|
print CFILE qq/#include "config.h"\n\n/;
|
|
print CFILE qq/#include "stamp-pdbgen.h"\n\n/;
|
|
print CFILE $headers, "\n";
|
|
print CFILE $extra->{decls}, "\n" if exists $extra->{decls};
|
|
print CFILE "\n", $extra->{code} if exists $extra->{code};
|
|
print CFILE $out->{code};
|
|
print CFILE "\nvoid\nregister_${group}_procs (PikaPDB *pdb)\n";
|
|
print CFILE "{\n PikaProcedure *procedure;\n$out->{register}}\n";
|
|
close CFILE;
|
|
&write_file($cfile, $destdir);
|
|
|
|
my $decl = "register_${group}_procs";
|
|
push @group_decls, $decl;
|
|
$longest = length $decl if $longest < length $decl;
|
|
|
|
$group_procs .= ' ' x 2 . "register_${group}_procs (pdb);\n";
|
|
$pcount += $out->{pcount};
|
|
}
|
|
|
|
if (! $ENV{PDBGEN_GROUPS}) {
|
|
my $internal = "$builddir/internal-procs.h$FILE_EXT";
|
|
open IFILE, "> $internal" or die "Can't open $internal: $!\n";
|
|
print IFILE $gpl;
|
|
my $guard = "__INTERNAL_PROCS_H__";
|
|
print IFILE <<HEADER;
|
|
#ifndef $guard
|
|
#define $guard
|
|
|
|
HEADER
|
|
|
|
print IFILE "void internal_procs_init" . ' ' x ($longest - length "internal_procs_init") . " (PikaPDB *pdb);\n\n";
|
|
|
|
print IFILE "/* Forward declarations for registering PDB procs */\n\n";
|
|
foreach (@group_decls) {
|
|
print IFILE "void $_" . ' ' x ($longest - length $_) . " (PikaPDB *pdb);\n";
|
|
}
|
|
|
|
print IFILE <<HEADER;
|
|
|
|
#endif /* $guard */
|
|
HEADER
|
|
close IFILE;
|
|
&write_file($internal, $destdir);
|
|
|
|
$internal = "$builddir/internal-procs.c$FILE_EXT";
|
|
open IFILE, "> $internal" or die "Can't open $internal: $!\n";
|
|
print IFILE $gpl;
|
|
print IFILE qq@#include "config.h"\n\n@;
|
|
print IFILE qq/#include "stamp-pdbgen.h"\n\n/;
|
|
print IFILE qq@#include <glib-object.h>\n\n@;
|
|
print IFILE qq@#include "pdb-types.h"\n\n@;
|
|
print IFILE qq@#include "pikapdb.h"\n\n@;
|
|
print IFILE qq@#include "internal-procs.h"\n\n@;
|
|
chop $group_procs;
|
|
print IFILE "\n/* $total procedures registered total */\n\n";
|
|
print IFILE <<BODY;
|
|
void
|
|
internal_procs_init (PikaPDB *pdb)
|
|
{
|
|
g_return_if_fail (PIKA_IS_PDB (pdb));
|
|
|
|
$group_procs
|
|
}
|
|
BODY
|
|
close IFILE;
|
|
&write_file($internal, $destdir);
|
|
}
|
|
}
|
|
|
|
1;
|
