1package Math::SymbolicX::ParserExtensionFactory;
2
3use 5.006;
4use strict;
5use warnings;
6use Carp;
7use Math::Symbolic;
8use Text::Balanced;
9
10our $BeenUsedBefore    = {};
11our $Functions         = {};
12our $Order             = [];
13our $RegularExpression = qr/(?!)/;
14
15our $VERSION = '3.02';
16
17sub import {
18  my $package = shift;
19  croak("Uneven number of arguments in usage of "
20    . "Math::SymbolicX::ParserExtensionFactory")
21    if @_ % 2;
22
23  my %args = @_;
24
25  _extend_parser();
26
27  foreach my $key ( keys %args ) {
28    croak("Invalid keys => value pairs as arguments in usage of "
29      . "Math::SymbolicX::ParserExtensionFactory")
30      if not ref( $args{$key} ) eq 'CODE';
31    if ( not exists $Functions->{$key} ) {
32      push @$Order, $key;
33    }
34    $Functions->{$key} = $args{$key};
35  }
36
37  $RegularExpression = _regenerate_regex($Order);
38
39  return ();
40}
41
42sub _extend_parser {
43
44  my $parser = shift;
45  $parser = $Math::Symbolic::Parser if not defined $parser;
46
47  # make sure there is a parser
48  if (not defined $parser) {
49    $parser = $Math::Symbolic::Parser = Math::Symbolic::Parser->new();
50  }
51
52  if ( not exists $BeenUsedBefore->{"$parser"} ) {
53    if ($parser->isa('Parse::RecDescent')) {
54      _extend_parser_recdescent($parser)
55    }
56    elsif ($parser->isa('Math::Symbolic::Parser::Yapp')) {
57      _extend_parser_yapp($parser);
58    }
59    else {
60      die "Unsupported parser type!";
61    }
62    $BeenUsedBefore->{"$parser"} = 1;
63  }
64}
65
66sub _extend_parser_yapp {
67  # This is a no-op since ::Parser::Yapp has built-in support for
68  # ::ParserExtensionFactory. This would probably not be possible
69  # otherwise.
70  return(1);
71}
72
73sub _extend_parser_recdescent {
74  my $parser = shift;
75  $parser->{__PRIV_EXT_FUNC_REGEX} = qr/(?!)/;
76  $parser->Extend(<<'EXTENSION');
77function: /$thisparser->{__PRIV_EXT_FUNC_REGEX}\s*(?=\()/ {extract_bracketed($text, '(')}
78  {
79    warn 'function_private_msx_parser_extension_factory '
80      if $Math::Symbolic::Parser::DEBUG;
81    my $function = $item[1];
82    $function =~ s/\s+$//;
83    my $argstring = substr($item[2], 1, length($item[2])-2);
84    die "Invalid extension function and/or arguments '$function$item[2]' ".
85        "(Math::SymbolicX::ParserExtensionFactory)"
86      if not exists
87         $thisparser->{__PRIV_EXT_FUNCTIONS}{$function};
88    my $result = $thisparser->{__PRIV_EXT_FUNCTIONS}{$function}->($argstring);
89    die "Invalid result of extension function application "
90        ."('$item[1]($argstring)'). Also refer to the "
91        ."Math::SymbolicX::ParserExtensionFactory manpage."
92      if ref($result) !~ /^Math::Symbolic/;
93    $return = $result;
94  }
95
96  | /$Math::SymbolicX::ParserExtensionFactory::RegularExpression\s*(?=\()/ {extract_bracketed($text, '(')}
97  {
98    warn 'function_global_msx_parser_extension_factory '
99      if $Math::Symbolic::Parser::DEBUG;
100    my $function = $item[1];
101    $function =~ s/\s+$//;
102    my $argstring = substr($item[2], 1, length($item[2])-2);
103    die "Invalid extension function and/or arguments '$function$item[2]' ".
104        "(Math::SymbolicX::ParserExtensionFactory)"
105      if not exists
106         $Math::SymbolicX::ParserExtensionFactory::Functions->{$function};
107    my $result = $Math::SymbolicX::ParserExtensionFactory::Functions->{$function}->($argstring);
108    die "Invalid result of extension function application "
109        ."('$item[1]($argstring)'). Also refer to the "
110        ."Math::SymbolicX::ParserExtensionFactory manpage."
111      if ref($result) !~ /^Math::Symbolic/;
112    $return = $result;
113  }
114
115EXTENSION
116  return(1);
117}
118
119sub _regenerate_regex {
120  my @arrays = @_;
121  my $string = join '|', map {"\Q$_\E"} map {@$_} @arrays;
122  return qr/(?!)/ if $string eq '';
123  return qr/(?:$string)/;
124}
125
126sub add_private_functions {
127  shift if not ref $_[0] and $_[0] eq __PACKAGE__;
128  my $parser = shift;
129  croak("Invalid number of arguments!") if @_ % 2;
130
131  $parser->{__PRIV_EXT_FUNCTIONS}  ||= {};
132  $parser->{__PRIV_EXT_FUNC_ORDER} ||= [];
133  while (@_) {
134    my $name = shift;
135    push @{$parser->{__PRIV_EXT_FUNC_ORDER}}, $name;
136    $parser->{__PRIV_EXT_FUNCTIONS}{$name} = shift;
137  }
138
139  $parser->{__PRIV_EXT_FUNC_REGEX} = _regenerate_regex( $parser->{__PRIV_EXT_FUNC_ORDER} );
140}
141
1421;
143__END__
144
145=head1 NAME
146
147Math::SymbolicX::ParserExtensionFactory - Generate parser extensions
148
149=head1 SYNOPSIS
150
151  use Math::Symbolic qw/parse_from_string/;
152
153  # This will extend all parser objects in your program:
154  use Math::SymbolicX::ParserExtensionFactory (
155
156    functionname => sub {
157      my $argumentstring = shift;
158      my $result = construct_some_math_symbolic_tree( $argumentstring );
159      return $result;
160    },
161
162    anotherfunction => sub {
163      ...
164    },
165
166  );
167
168  # ...
169  # Later in your code
170
171  my $formula = parse_from_string('variable * 4 * functionname(someargument)');
172
173  # use $formula as a Math::Symbolic object.
174  # Refer to Math::SymbolicX::BigNum (arbitrary precision arithmetic
175  # support through the Math::Big* modules) or to
176  # Math::SymbolicX::ComplexNumbers (complex number support) for examples.
177
178
179  # Alternative: modify a single parser object only:
180  my $parser = Math::Symbolic::Parser->new();
181
182  Math::SymbolicX::ParserExtensionFactory->add_private_functions(
183    $parser,
184    fun_function => sub {...},
185    my_function  => sub {...},
186    ...
187  );
188
189=head1 DESCRIPTION
190
191This module provides a simple way to extend the Math::Symbolic parser with
192arbitrary functions that return any valid Math::Symbolic tree.
193The return value of the function call is
194inserted into the complete parse tree at the point at which the function
195call is parsed. Familiarity with the Math::Symbolic module will be
196assumed throughout the documentation.
197
198This module is not object oriented. It does not export anything. You should
199not call any subroutines directly nor should you modify any class data
200directly. The complete interface is the call to
201C<use Math::SymbolicX::ParserExtensionFactory> and its arguments. The reason
202for the long module name is that you should not have to call it multiple times
203in your code because it modifies the parser for good. It is intended to be
204a pain to type. :-)
205
206The aim of the module is to allow for hooks into the parser without modifying
207the parser yourself because that requires rather in-depth knowledge of the
208module code. By specifying key => value pairs of function names and
209function implementations (code references) as arguments to the use() call
210of the module, this module extends the parser that is stored in the
211C<$Math::Symbolic::Parser> variable with the specified functions and whenever
212"C<yourfunction(any argument string with balanced parenthesis)>" occurs
213in the code, the subroutine reference is called with the argument string as
214argument.
215
216The subroutine is expected to return any Math::Symbolic tree. That means,
217as of version 0.506 of Math::Symbolic, a Math::Symbolic::Operator, a
218Math::Symbolic::Variable,
219or a Math::Symbolic::Constant object. The returned object will be incorporated
220into the Math::Symbolic tree that results from the parse at the exact position
221at which the custom function call was parsed.
222
223Please note that the usage of this module will be quite slow at compile time
224because it has to regenerate the complete Math::Symbolic parser the first
225time you use this module in your code. The run time performance penalty
226should be low, however.
227
228=head1 FUNCTIONS
229
230=head2 add_private_functions
231
232Callable as class method or function. First argument must be the parser
233object to modify (either a Parse::RecDescent or a Parse::Yapp based
234Math::Symbolic parser), followed by key/value pairs of function names
235and code refs (implementations).
236
237Modifies only the parser passed in as first argument. For an example,
238see synopsis above.
239
240=head1 CAVEATS
241
242Since version 2.00 of this module, the old, broken parsing of the argument
243string which would fail on nested, unescaped parenthesis was replaced
244by a better routine which will correctly parse nested pairs of parenthesis.
245
246On the flip side, if the argument string contains unmatched parenthesis,
247the parse will fail. Examples:
248
249  "myfunction(foo(bar)" # fails because missing closing parenthesis
250
251Escaping of parenthesis in the argument string B<is no longer supported>.
252
253=head1 AUTHOR
254
255Copyright (C) 2003-2009 Steffen Mueller
256
257This library is free software; you can redistribute it and/or modify
258it under the same terms as Perl itself.
259
260You may contact the author at symbolic-module at steffen-mueller dot net
261
262Please send feedback, bug reports, and support requests to the Math::Symbolic
263support mailing list:
264math-symbolic-support at lists dot sourceforge dot net. Please
265consider letting us know how you use Math::Symbolic. Thank you.
266
267If you're interested in helping with the development or extending the
268module's functionality, please contact the developers' mailing list:
269math-symbolic-develop at lists dot sourceforge dot net.
270
271=head1 SEE ALSO
272
273New versions of this module can be found on
274http://steffen-mueller.net or CPAN.
275
276Also have a look at L<Math::Symbolic>,
277and at L<Math::Symbolic::Parser>
278
279Refer to L<Math::SymbolicX::BigNum> (arbitrary precision
280arithmetic support through the Math::Big* modules) or to
281L<Math::SymbolicX::ComplexNumbers> (complex number support) for examples.
282
283=cut
284