[glibmm/gmmproc-refactor] Change taghandlerwriter.pl to parse the gir structure file.
- From: Krzesimir Nowak <krnowak src gnome org>
- To: commits-list gnome org
- Cc:
- Subject: [glibmm/gmmproc-refactor] Change taghandlerwriter.pl to parse the gir structure file.
- Date: Mon, 21 Nov 2011 12:05:00 +0000 (UTC)
commit 49482868c141685ee25db1f406eb154d5b728fef
Author: Krzesimir Nowak <qdlacz gmail com>
Date: Mon Nov 21 12:34:30 2011 +0100
Change taghandlerwriter.pl to parse the gir structure file.
Now generating perl modules is faster and independent from
generated gir files, which may lack some attributes or tags.
Also, it generates API objects and an XML documentation. The latter
is experimental and not used by default though. It was meant to
generate a documentation for gobject-introspection, because the
one there is old and incomplete.
tools/pm/modules.ignore | 10 -
tools/pm/run_thw.sh | 86 +++--
tools/pm/taghandlerwriter.pl | 986 +++++++++++++++++++++++++++++-------------
3 files changed, 733 insertions(+), 349 deletions(-)
---
diff --git a/tools/pm/run_thw.sh b/tools/pm/run_thw.sh
index 76cbc31..abf45f1 100755
--- a/tools/pm/run_thw.sh
+++ b/tools/pm/run_thw.sh
@@ -22,9 +22,24 @@ opt_o_val=''
opt_p=0
opt_p_val=''
-if test ! -x 'taghandlerwriter.pl'
+opt_api_o=0
+opt_api_o_val=''
+opt_api_p=0
+opt_api_p_val=''
+
+struct_file='gir_structure'
+
+if test ! -f "${struct_file}"
+then
+ echo "No ${struct_file} found. Bailing out." >&2
+ exit 1
+fi
+
+script_file='taghandlerwriter.pl'
+
+if test ! -x "${script_file}"
then
- echo 'taghandlerwriter.pl either does not exist or is not an executable. Bailing out.' >&2
+ echo "${script_file} either does not exist or is not an executable. Bailing out." >&2
exit 1
fi
@@ -34,16 +49,30 @@ do
then
opt_o=2
opt_o_val=${opt}
+ elif test ${opt_api_o} -eq 1
+ then
+ opt_api_o=2
+ opt_api_o_val=${opt}
elif test ${opt_p} -eq 1
then
opt_p=2
opt_p_val=${opt}
+ elif test ${opt_api_p} -eq 1
+ then
+ opt_api_p=2
+ opt_api_p_val=${opt}
elif test "x${opt}" = 'x-o'
then
opt_o=1
+ elif test "x${opt}" = 'x-d'
+ then
+ opt_api_o=1
elif test "x${opt}" = 'x-p'
then
opt_p=1
+ elif test "x${opt}" = 'x-a'
+ then
+ opt_api_p=1
else
echo "Unknown option: ${opt}. Bailing out." >&2
exit 1
@@ -62,41 +91,42 @@ then
exit 1
fi
+if test ${opt_api_o} -eq 1
+then
+ echo "-d option needs value. Bailing out." >&2
+ exit 1
+fi
+
+if test ${opt_api_p} -eq 1
+then
+ echo "-a option needs value. Bailing out." >&2
+ exit 1
+fi
+
if test ${opt_o} -eq 0
then
- opt_o_val='Gir/Handlers/Generated'
+ opt_o_val='Gir/Handlers'
echo "No -o option given. Output directory is set to ${opt_o_val}."
fi
if test ${opt_p} -eq 0
then
- opt_p_val='Gir::Handlers::Generated'
+ opt_p_val='Gir::Handlers'
echo "No -p option given. Package prefix is set to ${opt_p_val}."
fi
-girdir=''
-pkgconfinv='pkg-config --variable=girdir gobject-introspection-1.0'
-if $pkgconfinv >/dev/null 2>&1
+if test ${opt_api_o} -eq 0
then
- girdir=`$pkgconfinv`
+ opt_api_o_val='Gir/Api'
+ echo "No -d option given. API output directory is set to ${opt_api_o_val}."
fi
-if test "x${girdir}" = 'x' || test ! -d "${girdir}"
+if test ${opt_api_p} -eq 0
then
- echo 'Bad gir directory or pkg-config invocation failed. Bailing out.' >&2
- exit 1
+ opt_api_p_val='Gir::Api'
+ echo "No -a option given. Package prefix is set to ${opt_api_p_val}."
fi
-for d in "${girdir}"/*.gir
-do
- if test "x${d}" = "x${girdir}"'/*.gir'
- then
- echo "No gir files in $girdir. Bailing out." >&2
- exit 1
- fi
- break
-done
-
commondir="${opt_o_val}/Common"
if test ! -e "${commondir}"
then
@@ -107,12 +137,14 @@ then
exit 1
fi
-modignore=''
-if test ! -f 'modules.ignore'
+apicommondir="${opt_api_o_val}/Common"
+if test ! -e "${apicommondir}"
+then
+ mkdir -p "${apicommondir}"
+elif test ! -d "${apicommondir}"
then
- echo 'No modules.ignore file found - handwritten gir files may have different structure.' >&2
-else
- modignore='-i modules.ignore'
+ echo "${apicommondir} already exists and is not a directory. Bailing out." >&2
+ exit 1
fi
-./taghandlerwriter.pl -o "${opt_o_val}" -p "${opt_p_val}" ${modignore} "${girdir}"/*
+"./${script_file}" -o "${opt_o_val}" -p "${opt_p_val}" -d "${opt_api_o_val}" -a "${opt_api_p_val}" -i "${struct_file}"
diff --git a/tools/pm/taghandlerwriter.pl b/tools/pm/taghandlerwriter.pl
index eb8dae8..9a21273 100755
--- a/tools/pm/taghandlerwriter.pl
+++ b/tools/pm/taghandlerwriter.pl
@@ -1,5 +1,5 @@
-#!/usr/bin/env perl
-
+#!/usr/bin/perl
+# -*- mode: perl; perl-indent-level: 2; indent-tabs-mode: nil -*-
## Copyright 2011 Krzesimir Nowak
##
## This program is free software; you can redistribute it and/or modify
@@ -17,17 +17,22 @@
## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
##
+##
+## TODO: Make a separate module from parse_my_file.
+## TODO: Make a separate module for code and docs generation.
+##
+
use strict;
use warnings;
use File::Spec;
use Getopt::Long;
use IO::File;
-use XML::Parser::Expat;
my $glob_magic_toplevel = 'top-level';
+my $glob_script_name = (File::Spec->splitpath ($0))[2];
my $glob_header =
-'## This file was generated by taghandlerwriter.pl script.
+'## This file was generated by ' . $glob_script_name . ' script.
##
## Copyright 2011 Krzesimir Nowak
##
@@ -46,194 +51,324 @@ my $glob_header =
## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
##';
+##
+## If no parameters are passed then it returns a newline.
+## If one parameter is passed then it returns the parameter with newline
+## appended to it.
+##
sub nl
{
return (shift or '') . "\n";
}
-sub setup_ignores($)
+##
+## Takes a line, parses it and gets a name of tag.
+##
+sub get_tag_from_line ($)
{
- my $filename = shift;
- my $fd = IO::File->new ($filename, 'r');
+ my $line_pair = shift;
+ my $line = $line_pair->[1];
- unless (defined ($fd))
+ $line = substr ($line, 2);
+ if ($line =~ /[^a-zA-Z0-9_:-]/)
{
- return ();
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': The only allowed characters in tags are a-z, A-Z, 0-9, underscore, colon and dash.');
}
- my @lines = $fd->getlines ();
- my %omit = ();
-
- $fd->close ();
- foreach my $line (@lines)
- {
- $line =~ s/\s*#.*//g;
- $line =~ s/^\s+//g;
- $line =~ s/\s+$//g;
- if ($line)
- {
- $omit{$line} = 0;
- }
- }
- return %omit;
+ return $line;
}
-sub handle_tree ($$$)
+##
+## Takes a line and macro store, applies macros to the line and returns it.
+sub apply_macros ($$)
{
- my ($expat, $tree, $tag) = @_;
- my @context = ($glob_magic_toplevel, $expat->context);
- my $root = $tree;
+ my ($line_pair, $macros) = @_;
+ my $plain_line = $line_pair->[1];
- foreach my $elem (@context)
+ while ($plain_line =~ /!([^!]*?)!/)
{
- unless (exists ($root->{$elem}))
+ my $used_macro = $1;
+
+ unless ($used_macro)
{
- $root->{$elem} = {};
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Cannot use empty macro.');
+ exit 1;
+ }
+ if ($used_macro =~ /[^a-zA-Z0-9_]/)
+ {
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': The only allowed characters in tags are a-z, A-Z, 0-9, and underscore.');
+ exit 1;
+ }
+ unless (exists $macros->{$used_macro})
+ {
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Use of the unknown macro `' . $used_macro . '\'.');
+ exit 1;
}
- my $href = $root->{$elem};
-
- $root = $href;
- }
- unless (exists ($root->{$tag}))
- {
- $root->{$tag} = {};
+ $plain_line =~ s/!$used_macro!/$macros->{$used_macro}/g;
}
+ return $plain_line;
}
-sub handle_attributes ($$$@)
+##
+## Takes a line and macro store, parses the line and gets a list of attributes.
+## Macro store is used in case of macro usage in line.
+##
+sub get_attributes_from_line ($$)
{
- my ($expat, $tags, $tag, @atts_vals) = @_;
+ my ($line_pair, $macros) = @_;
+ my $plain_line = apply_macros ($line_pair, $macros);
- unless (exists ($tags->{$tag}))
- {
- $tags->{$tag} = {'count' => 0, 'attributes' => {}};
- }
+ $plain_line = substr ($plain_line, 2);
- my $elem = $tags->{$tag};
- my $atts = $elem->{'attributes'};
- my $att = undef;
+ my @entries = split (',', $plain_line);
+ my $name = undef;
+ my $mode = undef;
+ my $value = undef;
+ my @attributes = ();
+ my %mode_to_bool =
+ (
+ 't' => 1,
+ 'f' => 0
+ );
- ++$elem->{'count'};
- foreach my $entry (@atts_vals)
+ for my $entry (@entries)
{
- unless (defined ($att))
+ if ($entry =~ /^\[/)
{
- $att = $entry;
+ if (defined ($name) or defined ($mode) or defined ($value))
+ {
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Badly formed attributes - probably previous attribute triplet is not closed.');
+ exit 1;
+ }
+
+ $name = substr ($entry, 1);
}
- else
+ elsif ($entry =~ /\]$/)
{
- if (exists ($atts->{$att}))
+ unless (defined ($mode))
{
- my $attribute = $atts->{$att};
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Badly formed attributes - no mode defined.');
+ exit 1;
+ }
- ++$attribute->{'count'};
+ $value = substr ($entry, 0, length ($entry) - 1);
- if (defined ($attribute->{'value'}) and $attribute->{'value'} ne $entry)
- {
- $attribute->{'value'} = undef;
- }
- }
- else
+ if ($value eq '')
{
- $atts->{$att} = {'count' => 1, 'value' => $entry};
+ $value = undef;
}
- $att = undef;
+
+ my $attribute =
+ {
+ 'name' => $name,
+ 'mandatory' => $mode,
+ 'default_value' => $value
+ };
+
+ push (@attributes, $attribute);
+ $name = undef;
+ $mode = undef;
+ $value = undef;
}
- }
-}
+ else
+ {
+ unless (defined $name)
+ {
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Badly formed attributes - no name defined.');
+ exit 1;
+ }
-sub add_file_to_list($$)
-{
- my ($file, $list) = @_;
+ unless (exists $mode_to_bool{$entry})
+ {
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Badly formed attributes - expected either `t\' or `f\' in mode field.');
+ exit 1;
+ }
- if ($file =~ /\.gir$/)
- {
- push (@{$list}, $file);
+ $mode = $mode_to_bool{$entry};
+ }
}
- else
+
+ if (defined $name or defined $mode or defined $value)
{
- print STDERR nl ('Not a gir file: ' . $file . '.');
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Badly formed attributes - line ended too early.');
+ exit 1;
}
+
+ @attributes = sort { $a->{'name'} cmp $b->{'name'} } @attributes;
+
+ return \ attributes;
}
-sub get_attributes_of_tag ($$)
+##
+## Takes a line and macro store, parses the line and gets a list of kids.
+## Macro store is used in case of macro usage in line.
+##
+sub get_kids_from_line ($$)
{
- my ($tagname, $tags) = @_;
- my @attributes = ();
- my $tag = $tags->{$tagname};
- my $atts = $tag->{'attributes'};
- my $total_count = $tag->{'count'};
+ my ($line_pair, $macros) = @_;
+ my $plain_line = apply_macros ($line_pair, $macros);
+ my @kids = sort (split (',', substr ($plain_line, 2)));
- while (my ($attribute, $desc) = each %{$atts})
- {
- my $mandatory = (($total_count == $desc->{'count'}) ? 1 : 0);
- my $single_value = $desc->{'value'};
- my $new_desc =
- {
- 'name' => $attribute,
- 'mandatory' => $mandatory,
- 'single_value' => $single_value
- };
- push (@attributes, $new_desc);
- }
+ return \ kids;
+}
- @attributes = sort { $a->{'name'} cmp $b->{'name'} } @attributes;
+##
+## Takes a line and macro store, parses the line and gets a list of parents.
+## Macro store is used in case of macro usage in line.
+##
+sub get_parents_from_line ($$)
+{
+ my ($line_pair, $macros) = @_;
+ my $plain_line = apply_macros ($line_pair, $macros);
+ my @parents = sort (split (',', substr ($plain_line, 2)));
- return \ attributes;
+ return \ parents;
}
-sub get_kids_of_tag ($$)
+##
+## Takes a line and macro store, parses the line and adds new macro to store.
+##
+sub add_new_macro ($$)
{
- my ($tag, $tree) = @_;
- my @kids = ();
- my @tags_queue = map { [$_, $tree] } sort keys %{$tree};
+ my ($line_pair, $macros) = @_;
+ my $line = substr ($line_pair->[1], 2);
+ my $first_comma = index ($line, ',');
- for my $pair (@tags_queue)
+ if ($first_comma < 1)
{
- my $subtree_tag = $pair->[0];
- my $subtree = $pair->[1];
- my $kid = $subtree->{$subtree_tag};
- my @kid_tags = sort keys %{$kid};
-
- if ($subtree_tag eq $tag)
- {
- push (@kids, @kid_tags);
- }
-
- push (@tags_queue, map { [$_, $kid] } @kid_tags);
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Empty macro name is not allowed.');
+ exit 1;
}
- my %unique_kids = ();
+ my $macro_name = substr ($line, 0, $first_comma);
- foreach my $kid (@kids)
+ if (exists $macros->{$macro_name})
{
- $unique_kids{$kid} = undef;
+ print STDERR nl ('`' . $line_pair->[1] . '\' at line ' . $line_pair->[0] . ': Macro `' . $macro_name . '\' was already defined.');
+ exit 1;
}
- @kids = sort keys %unique_kids;
+ my $macro_value = substr (apply_macros ($line_pair, $macros), 2 + $first_comma + 1);
- return \ kids;
+ $macros->{$macro_name} = $macro_value;
}
-sub merge_tree_and_tags ($$)
+##
+## Takes a filename, parses the file of given name and creates a structure
+## that looks as follows:
+## $tag =>
+## {
+## 'attributes' => [{'name' => attr1, 'mandatory' => 0/1, 'default_value' => ?/undef}, ...],
+## 'kids' => [tag1, ...]
+## 'parents' => [parent1, ...]
+## }
+##
+sub parse_my_file ($)
{
- my ($tree, $tags) = @_;
- my %merge = ();
+ my $filename = shift;
+ my $fd = IO::File->new ($filename, 'r');
- foreach my $tag (sort (keys %{$tags}, $glob_magic_toplevel))
+ unless (defined $fd)
{
- $merge{$tag} =
- {
- 'attributes' => get_attributes_of_tag ($tag, $tags),
- 'kids' => get_kids_of_tag ($tag, $tree)
- };
+ print STDERR nl ('Could not open file `' . $filename . '\' for reading.');
+ exit 1;
}
- return \%merge;
+ my @contents = $fd->getlines;
+
+ $fd->close;
+
+ my $current_tag = undef;
+ my $current_attributes = undef;
+ my $current_kids = undef;
+ my $current_parents = undef;
+ my %structure = ();
+ my %macros = ();
+ my $line_no = 0;
+
+ for my $line (@contents)
+ {
+ chomp $line;
+ ++$line_no;
+ next unless $line;
+ next if $line =~ /^#/;
+
+ my $line_pair = [$line_no, $line];
+
+ if ($line =~ /^t\^/)
+ {
+ if (defined $current_tag or defined $current_attributes or defined $current_kids or defined $current_parents)
+ {
+ print STDERR nl ('`' . $line . '\' at line ' . $line_no . ': Previous block was not finished.');
+ exit 1;
+ }
+ $current_tag = get_tag_from_line ($line_pair);
+
+ if (exists $structure{$current_tag})
+ {
+ print STDERR nl ('`' . $line . '\' at line ' . $line_no . ': Tag `' . $current_tag . '\' was already defined.');
+ exit 1;
+ }
+ }
+ elsif ($line =~ /^a\^/)
+ {
+ unless (defined $current_tag)
+ {
+ print STDERR nl ('`' . $line . '\' at line ' . $line_no . ': Expected t^.');
+ exit 1;
+ }
+
+ $current_attributes = get_attributes_from_line ($line_pair, \%macros);
+ }
+ elsif ($line =~ /^k\^/)
+ {
+ unless (defined $current_attributes)
+ {
+ print STDERR nl ('`' . $line . '\' at line ' . $line_no . ': Expected a^.');
+ exit 1;
+ }
+
+ $current_kids = get_kids_from_line ($line_pair, \%macros);
+ }
+ elsif ($line =~ /^p\^/)
+ {
+ unless (defined $current_kids)
+ {
+ print STDERR nl ('`' . $line . '\' at line ' . $line_no . ': Expected k^.');
+ exit 1;
+ }
+
+ $current_parents = get_parents_from_line ($line_pair, \%macros);
+ $structure{$current_tag} =
+ {
+ 'attributes' => $current_attributes,
+ 'kids' => $current_kids,
+ 'parents' => $current_parents
+ };
+
+ $current_tag = undef;
+ $current_attributes = undef;
+ $current_kids = undef;
+ $current_parents = undef;
+ }
+ elsif ($line =~ /^m\^/)
+ {
+ add_new_macro ($line_pair, \%macros);
+ }
+ else
+ {
+ print STDERR nl ('`' . $line . '\' at line ' . $line_no . ': Could not parse this line.');
+ exit 1;
+ }
+ }
+ return \%structure;
}
+##
+## Takes tag name and transforms it so it can be used as a function name.
+##
sub func_from_tag ($)
{
my $tag = shift;
@@ -244,6 +379,10 @@ sub func_from_tag ($)
return $func_tag;
}
+##
+## Takes data structure, output directory, package prefix and writes handlers
+## for every tag's attributes.
+##
sub write_tag_handlers ($$$)
{
my ($merge, $output_dir, $package_prefix) = @_;
@@ -267,7 +406,7 @@ sub write_tag_handlers ($$$)
nl ('use strict;') .
nl ('use warnings;') .
nl () .
- nl ('use Gir::Handlers::Generated::Common::Misc;') .
+ nl ('use ' . $package_prefix . '::Common::Misc;') .
nl ();
my @handlers = ();
@@ -285,41 +424,28 @@ sub write_tag_handlers ($$$)
foreach my $att (@{$attributes})
{
my $att_name = $att->{'name'};
+ my $default_value = $att->{'default_value'};
+
+ unless (defined ($default_value))
+ {
+ $default_value = 'undef';
+ }
+
+ my $pair = [$att_name, $default_value];
if ($att->{'mandatory'})
{
- push (@mandatory_atts, $att_name);
+ push (@mandatory_atts, $pair);
}
else
{
- my $single_value = $att->{'single_value'};
-
- if (defined ($single_value))
- {
- if ($single_value eq '0')
- {
- $single_value = '1';
- }
- elsif ($single_value eq '1')
- {
- $single_value = '0';
- }
- else
- {
- $single_value = 'undef';
- }
- }
- else
- {
- $single_value = 'undef';
- }
- push (@optional_atts, [$att_name, $single_value]);
+ push (@optional_atts, $pair);
}
}
my $handler .= nl ('sub get_' . func_from_tag ($tag) . '_params (@)') .
nl ('{') .
- nl (' return Gir::Handlers::Generated::Common::Misc::extract_values') .
+ nl (' return ' . $package_prefix . '::Common::Misc::extract_values') .
nl (' (') .
nl (' [');
@@ -328,7 +454,7 @@ sub write_tag_handlers ($$$)
foreach my $att (@mandatory_atts)
{
- push (@att_lines, ' \'' . $att . '\'');
+ push (@att_lines, ' [\'' . $att->[0] . '\', ' . $att->[1] . ']');
}
$handler .= nl (join (nl (','), @att_lines)) .
nl (' ],') .
@@ -352,12 +478,15 @@ sub write_tag_handlers ($$$)
$contents .= nl (join (nl (), sort (@handlers))) .
nl ('1; # indicate proper module load.');
$tags_handlers_fd->print ($contents);
- $tags_handlers_fd->close ();
+ $tags_handlers_fd->close;
}
+##
+## This unreadable function takes tag as a parameter and transforms it so it
+## can be used as a package name.
+##
sub module_from_tag ($)
{
- # unreadable, huh?
# - splits 'foo-BAR:bAz' to 'foo', 'BAR' and 'bAz'
# - changes 'foo' to 'Foo', 'BAR' to 'Bar' and 'bAz' to 'Baz'
# - joins 'Foo', 'Bar' and 'Baz' into one string 'FooBarBaz'
@@ -365,9 +494,13 @@ sub module_from_tag ($)
return join ('', map { ucfirst lc } split (/\W+/, shift));
}
-sub write_tag_modules ($$$)
+##
+## Takes data structure, output directory, package prefix and writes handlers
+## for every tag's children.
+##
+sub write_tag_modules ($$$$)
{
- my ($merge, $output_dir, $package_prefix) = @_;
+ my ($merge, $output_dir, $package_prefix, $api_package_prefix) = @_;
foreach my $tag (sort keys %{$merge})
{
@@ -385,9 +518,8 @@ sub write_tag_modules ($$$)
my $kids = $merge->{$tag}{'kids'};
my $package_name = $package_prefix . '::' . $pm;
- my @uses = ();
- my @default_start_impls = ();
- my @default_end_impls = ();
+ my @api_uses = ();
+ my @handler_uses = ();
my @start_bodies = ();
my @end_bodies = ();
my @start_store = ();
@@ -397,54 +529,45 @@ sub write_tag_modules ($$$)
foreach my $kid (@{$kids})
{
my $kid_module = $package_prefix . '::' . module_from_tag ($kid);
+ my $kid_object = $api_package_prefix . '::' . module_from_tag ($kid);
my $kid_func = func_from_tag ($kid);
my $kid_start = '_' . $kid_func . '_start';
- my $kid_start_impl = $kid_start . '_impl';
my $kid_end = '_' . $kid_func . '_end';
- my $kid_end_impl = $kid_end . '_impl';
- my $use = 'use ' . $kid_module . ';';
- my $start_impl = nl ('sub ' . $kid_start_impl . ' ($$$)') .
- nl ('{') .
- nl (' my $self = shift;') .
- nl () .
- nl (' unless ($self->_is_start_ignored (\'' . $kid . '\'))') .
- nl (' {') .
- nl (' #TODO: throw something.') .
- nl (' print STDERR \'' . $package_name . '::' . $kid_start_impl . ' not implemented.\' . "\\n";') .
- nl (' exit (1);') .
- nl (' }') .
- nl ('}');
- my $end_impl = nl ('sub ' . $kid_end_impl . ' ($$)') .
- nl ('{') .
- nl (' my $self = shift;') .
- nl () .
- nl (' unless ($self->_is_end_ignored (\'' . $kid . '\'))') .
- nl (' {') .
- nl (' #TODO: throw something.') .
- nl (' print STDERR \'' . $package_name . '::' . $kid_end_impl . ' not implemented.\' . "\\n";') .
- nl (' exit (1);') .
- nl (' }') .
- nl ('}');
+ my $api_use = 'use ' . $kid_object . ';';
+ my $handler_use = 'use ' . $kid_module . ';';
my $start_body = nl ('sub ' . $kid_start . ' ($$@)') .
nl ('{') .
nl (' my ($self, $parser, @atts_vals) = @_;') .
nl (' my $params = ' . $package_prefix . '::Common::Tags::get_' . $kid_func . '_params (@atts_vals);') .
+ nl (' my $state = $parser->get_current_state;') .
+ nl (' my $object = ' . $kid_object . '->new_with_params ($params);') .
nl () .
- nl (' $self->' . $kid_start_impl . ' ($parser, $params);') .
+ nl (' $state->push_object ($object);') .
+ nl (' $self->_call_start_hooks (\'' . $kid . '\');') .
nl ('}');
my $end_body = nl ('sub ' . $kid_end . ' ($$)') .
nl ('{') .
nl (' my ($self, $parser) = @_;') .
nl () .
- nl (' $self->' . $kid_end_impl . ' ($parser);') .
+ nl (' $self->_call_end_hooks (\'' . $kid . '\');') .
+ nl () .
+ nl (' my $state = $parser->get_current_state;') .
+ nl (' my $object = $state->get_current_object;') .
+ nl () .
+ nl (' $state->pop_object;') .
+ nl () .
+ nl (' my $parent_object = $state->get_current_object;') .
+ nl (' my $count = $parent_object->get_g_' . $kid_func . '_count;') .
+ nl (' my $name = ' . $package_prefix . '::Common::Misc::get_object_name ($object, $count);') .
+ nl () .
+ nl (' $parent_object->add_g_' . $kid_func . ' ($name, $object);') .
nl ('}');
- my $start_store_member = ' \'' . $kid . '\' => \\&' . $kid_start;
- my $end_store_member = ' \'' . $kid . '\' => \\&' . $kid_end;
- my $subhandler = ' \'' . $kid . '\'';
+ my $start_store_member = ' \'' . $kid . '\' => \\&' . $kid_start;
+ my $end_store_member = ' \'' . $kid . '\' => \\&' . $kid_end;
+ my $subhandler = ' \'' . $kid . '\' => \'' . $kid_module . '\'';
- push (@uses, $use);
- push (@default_start_impls, $start_impl);
- push (@default_end_impls, $end_impl);
+ push (@api_uses, $api_use);
+ push (@handler_uses, $handler_use);
push (@start_bodies, $start_body);
push (@end_bodies, $end_body);
push (@start_store, $start_store_member);
@@ -459,172 +582,411 @@ sub write_tag_modules ($$$)
nl ('use strict;') .
nl ('use warnings;') .
nl () .
- nl ('use parent qw(Gir::Handlers::Generated::Common::Base);') .
- nl () .
- nl ('use Gir::Handlers::Generated::Common::Store;') .
- nl ('use Gir::Handlers::Generated::Common::Tags;') .
- nl (join (nl (), @uses)) .
+ nl ('use parent qw(' . $package_prefix . '::Common::Base);') .
nl () .
- nl ('##') .
- nl ('## private virtuals') .
- nl ('##') .
- nl (join (nl (), @default_start_impls)) .
- nl (join (nl (), @default_end_impls)) .
- nl ('sub _setup_handlers ($)') .
- nl ('{') .
- nl (' my $self = shift;') .
- nl () .
- nl (' $self->_set_handlers') .
- nl (' (') .
- nl (' Gir::Handlers::Generated::Common::Store->new') .
- nl (' ({') .
- nl (join (nl (','), @start_store)) .
- nl (' }),') .
- nl (' Gir::Handlers::Generated::Common::Store->new') .
- nl (' ({') .
- nl (join (nl (','), @end_store)) .
- nl (' })') .
- nl (' );') .
- nl ('}') .
+ nl (join (nl (), @api_uses)) .
nl () .
- nl ('sub _setup_subhandlers ($)') .
- nl ('{') .
- nl (' my $self = shift;') .
+ nl ('use ' . $package_prefix . '::Common::Misc;') .
+ nl ('use ' . $package_prefix . '::Common::Store;') .
+ nl ('use ' . $package_prefix . '::Common::Tags;') .
nl () .
- nl (' $self->_set_subhandlers') .
- nl (' (') .
- nl (' $self->_generate_subhandlers') .
- nl (' ([') .
- nl (join (nl (','), @subhandlers)) .
- nl (' ])') .
- nl (' );') .
- nl ('}') .
+ nl (join (nl (), @handler_uses)) .
nl () .
nl ('##') .
- nl ('## private (sort of)') .
+ nl ('## private:') .
nl ('##') .
nl (join (nl (), @start_bodies)) .
nl (join (nl (), @end_bodies)) .
nl ('##') .
- nl ('## public') .
+ nl ('## public:') .
nl ('##') .
nl ('sub new ($)') .
nl ('{') .
nl (' my $type = shift;') .
nl (' my $class = (ref ($type) or $type or \'' . $package_name . '\');') .
- nl (' my $self = $class->SUPER::new ();') .
+ nl (' my $start_store = ' . $package_prefix . '::Common::Store->new') .
+ nl (' ({') .
+ nl (join (nl (','), @start_store)) .
+ nl (' });') .
+ nl (' my $end_store = ' . $package_prefix . '::Common::Store->new') .
+ nl (' ({') .
+ nl (join (nl (','), @end_store)) .
+ nl (' });') .
+ nl (' my $subhandlers =') .
+ nl (' {') .
+ nl (join (nl(','), @subhandlers)) .
+ nl (' };') .
+ nl (' my $self = $class->SUPER::new ($start_store, $end_store, $subhandlers);') .
nl () .
nl (' return bless ($self, $class);') .
nl ('}') .
nl () .
nl ('1; # indicate proper module load.');
$tags_module_fd->print ($contents);
- $tags_module_fd->close ();
+ $tags_module_fd->close;
}
}
-sub main()
+##
+## Takes data structure, output directory, package prefix and writes API objects
+## for every tag.
+##
+sub write_api_objects ($$$)
{
- my $ignore_file = undef;
- my $output_dir = undef;
- my $package_prefix = undef; # Gir::Handlers::Generated::Tags
- my @files_to_parse = ();
- my $opt_parse_result = GetOptions ('ignore-file|i=s' => \$ignore_file,
- 'output-dir|d=s' => \$output_dir,
- 'package-prefix|p=s' => \$package_prefix,
- '<>' => sub { add_file_to_list ($_[0], \ files_to_parse); }
- );
+ my ($merge, $output_dir, $package_prefix) = @_;
- if (not $opt_parse_result or not @files_to_parse or not $output_dir or not $package_prefix)
+ foreach my $tag (sort keys %{$merge})
{
- print STDERR nl ('taghandlerwriter.pl PARAMS FILES.') .
- nl ('PARAMS:') .
- nl (' --output-dir=<name> | -o <name> - output directory') .
- nl (' --package-prefix=<prefix> | -p <prefix> - prefix for package names') .
- nl (' [--ignore-file=<filename> | -i <filename> - name of file containing a list of girs to ignore]') .
- nl ('FILES: gir files.');
- exit 1;
+ my $pm = module_from_tag ($tag);
+ my $api_module_name = File::Spec->catfile ($output_dir, $pm . '.pm');
+ my $api_module_fd = IO::File->new ($api_module_name, 'w');
+
+ unless (defined ($api_module_fd))
+ {
+ print STDERR nl ('Failed to open ' . $api_module_name . ' for writing.');
+ exit 1;
+ }
+
+ print STDOUT nl ('Writing ' . $api_module_name . '.');
+
+ my $tag_desc = $merge->{$tag};
+ my $kids = $tag_desc->{'kids'};
+ my $package_name = $package_prefix . '::' . $pm;
+ my @uses = ();
+ my @groups = ();
+ my @get_group_member_by_name_subs = ();
+ my @get_group_member_by_index_subs = ();
+ my @get_group_member_count_subs = ();
+ my @add_member_to_group_subs = ();
+
+ foreach my $kid (@{$kids})
+ {
+ my $kid_func = func_from_tag ($kid);
+ my $kid_group = 'group_' . $kid_func;
+ my $use = 'use ' . $package_prefix . '::' . module_from_tag ($kid) . ';';
+ my $group = ' \'' . $kid_group . '\'';
+ my $get_group_member_by_name_sub = nl ('sub get_g_' . $kid_func . '_by_name ($$)') .
+ nl ('{') .
+ nl (' my ($self, $name) = @_;') .
+ nl () .
+ nl (' return $self->_get_group_member_by_name (\'' . $kid_group . '\', $name);') .
+ nl ('}');
+ my $get_group_member_by_index_sub = nl ('sub get_g_' . $kid_func . '_by_index ($$)') .
+ nl ('{') .
+ nl (' my ($self, $index) = @_;') .
+ nl () .
+ nl (' return $self->_get_group_member_by_index (\'' . $kid_group . '\', $index);') .
+ nl ('}');
+ my $get_group_member_count_sub = nl ('sub get_g_' . $kid_func . '_count ($)') .
+ nl ('{') .
+ nl (' my $self = shift;') .
+ nl () .
+ nl (' return $self->_get_group_member_count (\'' . $kid_group . '\');') .
+ nl ('}');
+ my $add_member_to_group_sub = nl ('sub add_g_' . $kid_func . ' ($$$)') .
+ nl ('{') .
+ nl (' my ($self, $member_name, $member) = @_;') .
+ nl ('') .
+ nl (' $self->_add_member_to_group (\'' . $kid_group .'\', $member_name, $member);') .
+ nl ('}');
+
+ push (@uses, $use);
+ push (@groups, $group);
+ push (@get_group_member_by_name_subs, $get_group_member_by_name_sub);
+ push (@get_group_member_by_index_subs, $get_group_member_by_index_sub);
+ push (@get_group_member_count_subs, $get_group_member_count_sub);
+ push (@add_member_to_group_subs, $add_member_to_group_sub);
+ }
+
+ my $atts = $tag_desc->{'attributes'};
+ my @attributes = ();
+ my @get_attribute_subs = ();
+ my @set_attribute_subs = ();
+ my @set_params = ();
+
+ foreach my $att (@{$atts})
+ {
+ my $name = $att->{'name'};
+ my $attribute_func = func_from_tag ($name);
+ my $attribute_name = 'attribute_' . $attribute_func;
+ my $attribute = ' \'' . $attribute_name . '\'';
+ my $set_attribute_sub_name = 'set_a_' . $attribute_func;
+ my $get_attribute_sub = nl ('sub get_a_' . $attribute_func . ' ($)') .
+ nl ('{') .
+ nl (' my ($self) = @_;') .
+ nl () .
+ nl (' return $self->_get_attribute (\'' . $attribute_name . '\');') .
+ nl ('}');
+ my $set_attribute_sub = nl ('sub ' . $set_attribute_sub_name . ' ($$)') .
+ nl ('{') .
+ nl (' my ($self, $value) = @_;') .
+ nl () .
+ nl (' $self->_set_attribute (\'' . $attribute_name . '\', $value);') .
+ nl ('}');
+ my $set_param = ' $self->' . $set_attribute_sub_name . '($params->{\'' . $name . '\'});';
+
+ push (@attributes, $attribute);
+ push (@get_attribute_subs, $get_attribute_sub);
+ push (@set_attribute_subs, $set_attribute_sub);
+ push (@set_params, $set_param);
+ }
+
+ my $contents = nl ($glob_header) .
+ nl () .
+ nl ('package ' . $package_name . ';') .
+ nl () .
+ nl ('use strict;') .
+ nl ('use warnings;') .
+ nl () .
+ nl ('use parent qw(' . $package_prefix . '::Common::Base);') .
+ nl () .
+ nl (join (nl (), @uses)) .
+ nl () .
+ nl ('sub new ($)') .
+ nl ('{') .
+ nl (' my $type = shift;') .
+ nl (' my $class = (ref ($type) or $type or \'' . $package_name . '\');') .
+ nl (' my $groups =') .
+ nl (' [') .
+ nl (join (nl (','), @groups)) .
+ nl (' ];') .
+ nl (' my $attributes =') .
+ nl (' [') .
+ nl (join (nl (','), @attributes)) .
+ nl (' ];') .
+ nl (' my $self = $class->SUPER::new ($groups, $attributes);') .
+ nl () .
+ nl (' bless ($self, $class);') .
+ nl (' return $self;') .
+ nl ('}') .
+ nl () .
+ nl ('sub new_with_params ($$)') .
+ nl ('{') .
+ nl (' my ($type, $params) = @_;') .
+ nl (' my $self = ' . $package_name . '::new ($type);') .
+ nl () .
+ nl (join (nl (), @set_params)) .
+ nl () .
+ nl (' return $self;') .
+ nl ('}') .
+ nl () .
+ nl (join (nl (), @get_group_member_by_name_subs)) .
+ nl () .
+ nl (join (nl (), @get_group_member_by_index_subs)) .
+ nl () .
+ nl (join (nl (), @get_group_member_count_subs)) .
+ nl () .
+ nl (join (nl (), @add_member_to_group_subs)) .
+ nl () .
+ nl (join (nl (), @get_attribute_subs)) .
+ nl () .
+ nl (join (nl (), @set_attribute_subs)) .
+ nl () .
+ nl ('1; # indicate proper module load.');
+
+ $api_module_fd->print ($contents);
+ $api_module_fd->close;
}
+}
+
+##
+## Takes tag name and transforms it so it can be used as an XML name.
+##
+sub xml_from_tag ($)
+{
+ my $tag = shift;
+ my $func_tag = lc ($tag);
+
+ $func_tag =~ s/\W+/-/g;
- my %omit_files = ();
+ return $func_tag;
+}
+
+##
+## Takes data structure and writes docs for every tag into gi-gir-reference.xml.
+##
+sub write_docs ($)
+{
+ my $merge = shift;
+ my $docs_name = 'gi-gir-reference.xml';
+ my $docs_fd = IO::File->new ($docs_name, 'w');
- if (defined ($ignore_file))
+ unless (defined ($docs_fd))
{
- %omit_files = setup_ignores ($ignore_file);
+ print STDERR nl ('Failed to open ' . $docs_name . ' for writing.');
+ exit 1;
}
- my @used_files = ();
- my @omitted_files = ();
- # $tag =>
- # {
- # 'attributes' =>
- # {
- # $attribute =>
- # {
- # 'count' => $count,
- # 'value' => $value
- # }
- # }
- # 'count' => $count
- # }
- my $tags = {};
- # $tag =>
- # {
- # $kid1 =>
- # {
- # $grandkid1 => ...
- # $grandkid2 => ...
- # ...
- # }
- # $kid2 =>
- # {
- # $grandkid1 => ...
- # $grandkid2 => ...
- # ...
- # }
- # ...
- # }
- my $tree = {};
-
- for my $file (@files_to_parse)
+ print STDOUT nl ('Writing ' . $docs_name . '.');
+
+ my $contents = nl ('<chapter id="gi-gir-reference">') .
+ nl () .
+ nl (' <title>The GIR XML format</title>') .
+ nl () .
+ nl (' <para>') .
+ nl (' This chapter describes the GIR XML markup format.') .
+ nl (' </para>');
+ my @refsects = ();
+
+ foreach my $tag (sort keys %{$merge})
{
- my (undef, undef, $basename) = File::Spec->splitpath ($file);
+ if ($tag eq $glob_magic_toplevel)
+ {
+ next;
+ }
+
+ my $desc = $merge->{$tag};
+ my $parents = $desc->{'parents'};
+ my @parent_links = [];
- if (exists $omit_files{$basename})
+ foreach my $parent (@{$parents})
{
- print STDOUT nl ('Ignoring ' . $basename .'.');
- push (@omitted_files, $basename);
+ my $parent_link = ' <link linkend="gi-gir-' . xml_from_tag ($parent) . '">' . $parent . '</link>';
+
+ push (@parent_links, $parent_link);
}
- else
+
+ my $refsect = nl (' <refsect2 id="gi-gir-' . xml_from_tag ($tag) . '">') .
+ nl (' <title><emphasis>' . $tag . '</emphasis> node</title>') .
+ nl ();
+ my $parent_string = undef;
+
+ if (@parent_links > 1)
+ {
+ $parent_string = ' Parent nodes:';
+ }
+ elsif (@parent_links == 1)
+ {
+ $parent_string = ' Parent node:';
+ }
+
+ if (defined ($parent_string))
+ {
+ $refsect += nl ($parent_string) .
+ nl (join (nl (','), @parent_links) . '.');
+ }
+
+ my $kids = $desc->{'kids'};
+ my @kid_links = [];
+
+ foreach my $kid (@{$kids})
+ {
+ my $kid_link = ' <link linkend="gi-gir-' . xml_from_tag ($kid) . '">' . $kid . '</link>';
+
+ push (@kid_links, $kid_link);
+ }
+
+ if (@{$kids})
+ {
+ $refsect += nl (' Possible children:') .
+ nl (join (nl (','), @kid_links) . '.');
+ }
+
+ my $attributes = $desc->{'attributes'};
+ my @mandatory_atts = ();
+ my @optional_atts = ();
+
+ foreach my $att (@{$attributes})
{
- print STDOUT nl ('Parsing ' . $basename . '.');
- push (@used_files, $basename);
+ my $att_name = $att->{'name'};
+ my $default_value = $att->{'default_value'};
+ my $att_string = $att_name;
- my $parser = XML::Parser::Expat->new ();
+ if (defined $default_value)
+ {
+ $att_string .= ' (' . $default_value . ')';
+ }
+
+ if ($att->{'mandatory'})
+ {
+ push (@mandatory_atts, $att_string);
+ }
+ else
+ {
+ push (@optional_atts, $att_string);
+ }
+ }
- $parser->setHandlers
- (
- 'Start' => sub {handle_attributes ($_[0], $tags, $_[1], @_[2 .. @_ - 1]); handle_tree ($_[0], $tree, $_[1])}
- );
- $parser->parsefile ($file);
- $parser->release ();
+ if (@mandatory_atts)
+ {
+ $refsect += nl (' Mandatory attributes (mandatory value when such exists):') .
+ nl (join (nl (','), @mandatory_atts) . '.');
}
+ if (@optional_atts)
+ {
+ $refsect += nl (' Optional attributes (default value when attribute is not specified):') .
+ nl (join (nl (','), @optional_atts) . '.');
+ }
+
+ $refsect += nl (' <example>') .
+ nl (' <title>A GIR fragment showing an namespace node</title>') .
+ nl (' <programlisting><![CDATA[') .
+ nl (' TODO]]></programlisting>') .
+ nl (' </example>') .
+ nl () .
+ nl (' </refsect2>');
+ push (@refsects, $refsect);
}
- # $tag =>
- # {
- # 'attributes' => [{'name' => attr1, 'mandatory' => 0/1, 'single_value' => ?/undef}, ...],
- # 'kids' => [tag1, ...]
- # }
- my $merge = merge_tree_and_tags ($tree, $tags);
+ $contents .= nl (join (nl (), sort (@refsects))) .
+ nl ('</chapter>');
+ $docs_fd->print ($contents);
+ $docs_fd->close;
+}
+
+##
+## This is where script begins - this function parses parameters, then parses
+## file given as parameter and outputs some files.
+##
+sub main()
+{
+ my $output_dir = undef;
+ my $package_prefix = undef; # Gir::Handlers
+ my $api_package_prefix = undef; # Gir::Api
+ my $api_output_dir = undef;
+ my $file_to_parse = ();
+ my $generate_docs = 0;
+ my $help = 0;
+ my $opt_parse_result = GetOptions ('output-dir|o=s' => \$output_dir,
+ 'package-prefix|p=s' => \$package_prefix,
+ 'api-package-prefix|a=s' => \$api_package_prefix,
+ 'api-output-dir|d=s' => \$api_output_dir,
+ 'generate-docs|g' => \$generate_docs,
+ 'help|h' => \$help,
+ 'input-file|i=s' => \$file_to_parse
+ );
- $tags = undef;
- $tree = undef;
- write_tag_handlers ($merge, $output_dir, $package_prefix);
- write_tag_modules ($merge, $output_dir, $package_prefix);
+ if (not $opt_parse_result or not $file_to_parse or not $output_dir or
+ not $package_prefix or not $api_package_prefix or not $api_output_dir
+ or $help
+ )
+ {
+ print STDERR nl ($glob_script_name . ' PARAMS') .
+ nl ('PARAMS:') .
+ nl (' --help | -h - this help') .
+ nl (' --output-dir=<name> | -o <name> - output directory') .
+ nl (' --package-prefix=<prefix> | -p <prefix> - prefix for package names') .
+ nl (' --api-package-prefix=<prefix> | -a <prefix> - prefix for api package names') .
+ nl (' --api-output-dir=<name> | -d <name> - output directory for api packages') .
+ nl (' [--input-file=<filename> | -i <filename> - name of file containing a description of structure]') .
+ nl (' [--generate-docs | -g - generate documentation]');
+ exit not $help;
+ }
+
+ print STDOUT nl ('Parsing ' . (File::Spec->splitpath ($file_to_parse))[2] . '.');
+
+ my $structure = parse_my_file ($file_to_parse);
+
+ write_tag_handlers ($structure, $output_dir, $package_prefix);
+ write_tag_modules ($structure, $output_dir, $package_prefix, $api_package_prefix);
+ write_api_objects ($structure, $api_output_dir, $api_package_prefix);
+ if ($generate_docs)
+ {
+ write_docs ($structure);
+ }
exit 0;
}
-#run!
-main();
+# Go!
+main;
[
Date Prev][
Date Next] [
Thread Prev][
Thread Next]
[
Thread Index]
[
Date Index]
[
Author Index]
