lib/manakai/genlib.pl

#!/usr/bin/perl -w
use strict;

=head1 NAME

genlib.pl - Source code generation utilities

=head1 DESCRIPTION

This Perl library provides a number of functions useful to 
generate source code fragment, including Perl code, in the 
C<main> namespace.

This library is part of manakai. 

=head1 FUNCTIONS

This library provides a lot of utility functions, most of 
their names are prefixed to identity their functionality. 

=over 4

=item Global Variable C<$result>

If the global variable C<$result> has its value, 
it is printed when a C<valid_err> is reported. 

=cut

our $result;

=item output_result ($s)

Outputs the argument as an output to the default output (usually 
the standard output).  Applications of this library can redefine 
this function in their own code so that they customize the output 
if they want.  Otherwise, it is simply C<print>ed. 

=item Global Variable C<$ResultOutput> (default: C<STDOUT>)

The file handle to which the result is outputed. 

=cut

our $ResultOutput ||= \*STDOUT;
sub output_result ($) {
  print $ResultOutput shift;
}

=item Global Variable C<$NodePathKey> = [I<name1>, I<name2>,,,,]

This variable contains zero or more SuikaWikiConfig/2.0 element type 
name that should be considered as "element identifier" - when 
a C<valid_err> is reported with a node, its node path is also 
reported with values of these element if exists. 

=cut

our $NodePathKey = [qw/Name QName Label/];

=item valid_err $msg, node => $node

Reports that the source data is something wrong (validness error) 
and that the script is unable to continue the operation, and dies. 
If the optional C<$node> argument is specified, its node path 
is outputed as the position at which the error occurs. 

=cut

sub valid_err ($;%) {
  my ($s, %opt) = @_;
  require Carp;
  output_result $result;
  if ($opt{node}) {
    if ($opt{node}->isa ('Message::Markup::SuikaWikiConfig20::Node')) {
      $s = $opt{node}->node_path (key => $NodePathKey) . ': ' . $s;
    } elsif ($opt{node}->isa ('Message::DOM::IF::Node')) {
      $s = 'dom:nodeName ("'.$opt{node}->node_name . '"): ' . $s;
    }
  }
  Carp::croak ($s);
}

=item valid_warn $msg, node => $node

Warns a non-fatal validness problem, as C<valid_err> does, but dying. 

=cut

sub valid_warn ($;%) {
  my ($s, %opt) = @_;
  require Carp;
  if ($opt{node}) {
    $s = $opt{node}->node_path (key => 'Name') . ': ' . $s;
  }
  Carp::carp ($s);
}

=item impl_err $msg

Reports an implementation error and dies.  It is intended to be 
called when something unbelivale has happened.

=cut

sub impl_err ($;%) {
  require Carp;
  output_result $result;
  die shift ().Carp::longmess ();
}

=item impl_warn $msg

Warns some non-fatal implementation matter. 

=cut

sub impl_warn ($;%) {
  require Carp;
  Carp::carp (shift);
}

=item impl_msg $msg

Shows a message from the implementation.  Unlike C<impl_err> and 
C<impl_warn> it does not mean something broken. 

=cut

sub impl_msg ($;%) {
  require Carp;
  Carp::carp (shift);
}


=item \@uniqed = array_uniq \@array

Removes duplicated string from an array.

=cut

sub array_uniq ($) {
  my $a = shift;
  my @a;
  my %a;
  no warnings 'uninitialized';
  for (@$a) {
    push @a, $_ unless $a{$_}++;
  }
  \@a;
}


sub english_number ($;%) {
  my ($num, %opt) = @_;
  if ($num == 0) {
    qq<no $opt{singular}>;
  } elsif ($num == 1) {
    qq<a $opt{singular}>;
  } elsif ($num < 0) {
    qq<$num $opt{plural}>;
  } elsif ($num < 10) {
    [qw/0 1 two three four five seven six seven eight nine/]->[$num] . ' ' .
    $opt{plural};
  } else {
    qq<$num $opt{plural}>;
  }
} # english_number

sub english_list ($;%) {
  my ($list, %opt) = @_;
  if (@$list > 1) {
    $opt{connector} = defined $opt{connector}
                          ? qq< $opt{connector} > : qq<, >;
    join (', ', @$list[0..($#$list-1)]).$opt{connector}.
    $list->[-1];
  } else {
    $list->[0];
  }
} # english_list


sub perl_comment ($) {
  my $s = shift;
  $s =~ s/\n/\n## /g;
  $s =~ s/\n## $/\n/s;
  $s .= "\n" unless $s =~ /\n$/;
  $s = q<## > . $s;
  $s;
}

sub perl_statement ($) {
  my $s = shift;
  $s . ";\n";
}

sub perl_assign ($@) {
  my ($left, @right) = @_;
  $left . ' = ' . (@right > 1 ? '(' . join (', ', @right) . ')' : $right[0]);
}

sub perl_name ($;%) {
  my ($s, %opt) = @_;
  valid_err q<Uninitialized value in name>, node => $opt{node}
    unless defined $s;
  $s =~ s/[- ](.|$)/uc $1/ge;
  $s = ucfirst $s if $opt{ucfirst};
  $s = uc $s if $opt{uc};
  $s;
}

sub perl_internal_name ($) {
  my $s = shift;
  '_' . perl_name $s;
}

sub perl_inherit ($;$) {
  my ($isa, $mod) = @_;
  return '' unless @$isa;
  $isa = array_uniq $isa;

  if ($mod) {
    perl_statement 'push ' . perl_var (type => '@',
                                       local_name => 'ISA',
                                       package => {full_name => $mod}) .
                   ', ' . perl_list (@$isa);
  } else {
    perl_statement 'push our @ISA, ' . perl_list (@$isa);
  }
}

sub perl_sub (%) {
  my %opt = @_;
  my $r = 'sub ';
  $r .= $opt{name} . ' ' if $opt{name};
  $r .= '(' . $opt{prototype} . ') ' if defined $opt{prototype};
  $r .= "{\n";
  $r .= $opt{code};
  $r .= "}\n";
  $r;
}

sub perl_cases (@) {
  my $r = '';
  while (my ($when, $code) = splice @_, 0, 2) {
    $r .= $when ne 'else' ? qq<} elsif ($when) {\n$code\n>
                          : qq<} else {\n$code\n>;
  }
  $r =~ s/^\} els//;
  $r .= qq<}\n> if $r;
  $r = "\n" . $r if $r;
  $r;
}

sub perl_var (%) {
  my %opt = @_;
  my $r = $opt{type} || '';                   # $, @, *, &, $# or empty
  $r = $opt{scope} . ' ' . $r if $opt{scope}; # my, our or local
  my $pack = ref $opt{package} ? $opt{package}->{full_name} : $opt{package};
  $r .= $pack . '::' if $pack;
  impl_err q<Local name of variable must be specified>, %opt
    unless defined $opt{local_name};
  $r .= $opt{local_name};
  $r;
}

{
use re 'eval';
my $RegBlockContent;
$RegBlockContent = qr/(?>[^{}\\]*)(?>(?>[^{}\\]+|\\.|\{(??{$RegBlockContent})\})*)/s;
sub perl_code ($;%);
sub perl_code ($;%) {
  my ($s, %opt) = @_;
  valid_err q<Uninitialized value in perl_code>,
    node => $opt{node} unless defined $s;
  $s =~ s[<Q:([^<>]+)>|\b(null|true|false)\b][
    my ($q, $l) = ($1, $2);
    if (defined $q) {
      if ($q =~ /\}/) {
        valid_warn qq<Possible typo in the QName: "$q">;
      }
      perl_literal (expanded_uri ($q));
    } else {
      {true => 1, false => 0, null => 'undef'}->{$l};
    }
  ]ge;
## TODO: Ensure Message::Util::Error imported if try.
## ISSUE: __FILE__ & __LINE__ will break if multiline substition happens.
  $s =~ s{
    \b__([A-Z]+)
    (?:\{($RegBlockContent)\})?
    __\b
  }{
    my ($name, $data) = ($1, $2);
    my $r;
    if ($name eq 'DEEP') {   ## Deep Method Call
      $r = 'do { local $Error::Depth = $Error::Depth + 1;' . perl_code ($data) .
           '}';
    } elsif ($name eq 'FILE' or $name eq 'LINE' or $name eq 'PACKAGE') {
      $r = qq<__${name}__>;
    } else {
      valid_err qq<Preprocessing macro "$name" not supported>;
    }
    $r;
  }goex;
  $s;
}
}

{my $f = 0;
sub perl_code_source ($%) {
  my ($s, %opt) = @_;
  sprintf qq<\n#line %d "File <%s> Node <%s>"\n%s\n> .
          qq<#line 1 "File <%s> Chunk #%d"\n>,
    $opt{line} || 1, $opt{file} || '',
    $opt{path} || 'x:unknown ()', $s, 
    $opt{file} || '', ++$f;
}}

sub perl_code_literal ($) {
  my $s = shift;
  bless \$s, '__code';
}

sub perl_literal ($) {
  my $s = shift;
  unless (defined $s) {
    impl_warn q<Undefined value is passed to perl_literal ()>;
    return q<undef>;
  } elsif (ref $s eq 'ARRAY') {
    return q<[> . perl_list (@$s) . q<]>;
  } elsif (ref $s eq 'HASH') {
    return q<{> . perl_list (%$s) . q<}>;
  } elsif (ref $s eq 'CODE') {
    impl_err q<CODE reference cannot be serialized>;
  } elsif (ref $s eq '__code') {
    return $$s;
  } else {
    ## NOTE: Don't change quote char - perl_code depends this quote.
    $s =~ s/(['\\])/\\$1/g;
    return q<'> . $s . q<'>;
  }
}

sub perl_list (@) {
  join ', ', map perl_literal $_, @_;
}

sub perl_if ($$;$) {
  my ($condition, $true, $false) = @_;
  my $if = q<if>;
  unless (defined $true) {
    $if = q<unless>;
    $true = $false;
    $false = undef;
  }
  for ($true, $false) {
    $_ = "\n" . $_ if $_ and /\A#\w+/;
  }
  my $r = qq<\n$if ($condition) {\n>.
          qq<  $true>.
          qq<}>;
  if (defined $false) {
     $r .=  qq< else {\n>.
           qq<  $false>.
           qq<}>;
  }
  $r .= qq<\n>;
  $r;
} # perl_if


sub pod_comment (@) {
  (q<=begin comment>, @_, q<=end comment>);
}

sub pod_block (@) {
  my @v = grep ((defined and length), @_);
  join "\n\n", '', ($v[0] =~ /^=/ ? () : '=pod'), @v, '=cut', '';
}

sub pod_head ($$) {
  my ($level, $s) = @_;
  $s =~ s/\s+/ /g;
  if ($level < 5) {
    '=head' . $level . ' ' . $s;  ## pod has only head1-head4.
  } else {
    'B<' . $s . '>';
  }
}

sub pod_list ($@) {
  my $m = shift;
  ('=over ' . $m, @_, '=back');
}

sub pod_item ($) {
  my ($s) = @_;
  valid_err q<Uninitialized value in pod_item> unless defined $s;
  $s =~ s/\s+/ /g;
  '=item ' . $s;
}

sub pod_pre ($) {
  my $s = shift;
  return '' unless defined $s;
  $s =~ s/\n/\n  /g;
  '  ' . $s;
}

sub pod_para ($) {
  my $s = shift;
  return '' unless defined $s;
  $s =~ s/\n\s+/\n/g;
  $s;
}

sub pod_paras ($) {
  shift;
}

sub pod_cdata ($) {
  my $s = shift;
  $s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
  $s;
}

sub pod_code ($) {
  my $s = shift;
  $s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
  qq<C<$s>>;
}

sub pod_em ($) {
  my $s = shift;
  $s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
  qq<I<$s>>;
}

sub pod_dfn ($) {
  my $s = shift;
  $s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
  qq<I<$s>X<$s>>;
}

sub pod_char (%) {
  my %opt = @_;
  if ($opt{name}) {
    if ($opt{name} eq 'copy') {
      qq<E<169>>;
    } else {
      qq<E<$opt{name}>>;
    }
  } else {
    impl_err q<Bad parameter for "pod_char">;
  }
} # pod_char

sub pod_uri ($) {
  my $uri = shift;
  qq<E<lt>${uri}E<gt>>;
} # pod_uri

sub pod_mail ($) {
  my $mail = shift;
  qq<E<lt>${mail}E<gt>>;
} # pod_mail

sub pod_link (%) {
  my %opt = @_;
  if ($opt{label}) {
    $opt{label} .= '|';
  } else {
    $opt{label} = '';
  }
  if ($opt{section}) {
    qq<L<$opt{label}/"$opt{section}">>;
  } elsif ($opt{module}) {
    qq<L<$opt{label}$opt{module}>>;
  } else {
    impl_err q<Bad parameter for "pod_link">;
  }
}


sub muf_template ($) {
  my $s = shift;
  $s =~ s{<Q:([^<>]+)>}{           ## QName
    expanded_uri ($1)
  }ge;
  $s;
}

sub section (@) {
  my @r;
  while (my ($t, $s) = splice @_, 0, 2) {
    if ($t eq 'req' and (not defined $s or not length $s)) {
      return ();
    } elsif (defined $s and length $s) {
      push @r, $s;
    }
  }
  return @r;
}


sub rfc3339_date ($) {
  my @time = gmtime shift;
  sprintf q<%04d-%02d-%02dT%02d:%02d:%02d+00:00>,
          $time[5] + 1900, $time[4] + 1, @time[3,2,1,0];
}

sub version_date ($) {
  my @time = gmtime shift;
  sprintf q<%04d%02d%02d.%02d%02d>,
          $time[5] + 1900, $time[4] + 1, @time[3,2,1];
}

=back

=head1 LICENSE

Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2005/04/04 15:21:32 $
1	#!/usr/bin/perl -w
2	use strict;
3
4	=head1 NAME
5
6	genlib.pl - Source code generation utilities
7
8	=head1 DESCRIPTION
9
10	This Perl library provides a number of functions useful to
11	generate source code fragment, including Perl code, in the
12	C<main> namespace.
13
14	This library is part of manakai.
15
16	=head1 FUNCTIONS
17
18	This library provides a lot of utility functions, most of
19	their names are prefixed to identity their functionality.
20
21	=over 4
22
23	=item Global Variable C<$result>
24
25	If the global variable C<$result> has its value,
26	it is printed when a C<valid_err> is reported.
27
28	=cut
29
30	our $result;
31
32	=item output_result ($s)
33
34	Outputs the argument as an output to the default output (usually
35	the standard output). Applications of this library can redefine
36	this function in their own code so that they customize the output
37	if they want. Otherwise, it is simply C<print>ed.
38
39	=item Global Variable C<$ResultOutput> (default: C<STDOUT>)
40
41	The file handle to which the result is outputed.
42
43	=cut
44
45	our $ResultOutput \|\|= \*STDOUT;
46	sub output_result ($) {
47	print $ResultOutput shift;
48	}
49
50	=item Global Variable C<$NodePathKey> = [I<name1>, I<name2>,,,,]
51
52	This variable contains zero or more SuikaWikiConfig/2.0 element type
53	name that should be considered as "element identifier" - when
54	a C<valid_err> is reported with a node, its node path is also
55	reported with values of these element if exists.
56
57	=cut
58
59	our $NodePathKey = [qw/Name QName Label/];
60
61	=item valid_err $msg, node => $node
62
63	Reports that the source data is something wrong (validness error)
64	and that the script is unable to continue the operation, and dies.
65	If the optional C<$node> argument is specified, its node path
66	is outputed as the position at which the error occurs.
67
68	=cut
69
70	sub valid_err ($;%) {
71	my ($s, %opt) = @_;
72	require Carp;
73	output_result $result;
74	if ($opt{node}) {
75	if ($opt{node}->isa ('Message::Markup::SuikaWikiConfig20::Node')) {
76	$s = $opt{node}->node_path (key => $NodePathKey) . ': ' . $s;
77	} elsif ($opt{node}->isa ('Message::DOM::IF::Node')) {
78	$s = 'dom:nodeName ("'.$opt{node}->node_name . '"): ' . $s;
79	}
80	}
81	Carp::croak ($s);
82	}
83
84	=item valid_warn $msg, node => $node
85
86	Warns a non-fatal validness problem, as C<valid_err> does, but dying.
87
88	=cut
89
90	sub valid_warn ($;%) {
91	my ($s, %opt) = @_;
92	require Carp;
93	if ($opt{node}) {
94	$s = $opt{node}->node_path (key => 'Name') . ': ' . $s;
95	}
96	Carp::carp ($s);
97	}
98
99	=item impl_err $msg
100
101	Reports an implementation error and dies. It is intended to be
102	called when something unbelivale has happened.
103
104	=cut
105
106	sub impl_err ($;%) {
107	require Carp;
108	output_result $result;
109	die shift ().Carp::longmess ();
110	}
111
112	=item impl_warn $msg
113
114	Warns some non-fatal implementation matter.
115
116	=cut
117
118	sub impl_warn ($;%) {
119	require Carp;
120	Carp::carp (shift);
121	}
122
123	=item impl_msg $msg
124
125	Shows a message from the implementation. Unlike C<impl_err> and
126	C<impl_warn> it does not mean something broken.
127
128	=cut
129
130	sub impl_msg ($;%) {
131	require Carp;
132	Carp::carp (shift);
133	}
134
135
136
137	=item \@uniqed = array_uniq \@array
138
139	Removes duplicated string from an array.
140
141	=cut
142
143	sub array_uniq ($) {
144	my $a = shift;
145	my @a;
146	my %a;
147	no warnings 'uninitialized';
148	for (@$a) {
149	push @a, $_ unless $a{$_}++;
150	}
151	\@a;
152	}
153
154
155	sub english_number ($;%) {
156	my ($num, %opt) = @_;
157	if ($num == 0) {
158	qq<no $opt{singular}>;
159	} elsif ($num == 1) {
160	qq<a $opt{singular}>;
161	} elsif ($num < 0) {
162	qq<$num $opt{plural}>;
163	} elsif ($num < 10) {
164	[qw/0 1 two three four five seven six seven eight nine/]->[$num] . ' ' .
165	$opt{plural};
166	} else {
167	qq<$num $opt{plural}>;
168	}
169	} # english_number
170
171	sub english_list ($;%) {
172	my ($list, %opt) = @_;
173	if (@$list > 1) {
174	$opt{connector} = defined $opt{connector}
175	? qq< $opt{connector} > : qq<, >;
176	join (', ', @$list[0..($#$list-1)]).$opt{connector}.
177	$list->[-1];
178	} else {
179	$list->[0];
180	}
181	} # english_list
182
183
184	sub perl_comment ($) {
185	my $s = shift;
186	$s =~ s/\n/\n## /g;
187	$s =~ s/\n## $/\n/s;
188	$s .= "\n" unless $s =~ /\n$/;
189	$s = q<## > . $s;
190	$s;
191	}
192
193	sub perl_statement ($) {
194	my $s = shift;
195	$s . ";\n";
196	}
197
198	sub perl_assign ($@) {
199	my ($left, @right) = @_;
200	$left . ' = ' . (@right > 1 ? '(' . join (', ', @right) . ')' : $right[0]);
201	}
202
203	sub perl_name ($;%) {
204	my ($s, %opt) = @_;
205	valid_err q<Uninitialized value in name>, node => $opt{node}
206	unless defined $s;
207	$s =~ s/[- ](.\|$)/uc $1/ge;
208	$s = ucfirst $s if $opt{ucfirst};
209	$s = uc $s if $opt{uc};
210	$s;
211	}
212
213	sub perl_internal_name ($) {
214	my $s = shift;
215	'_' . perl_name $s;
216	}
217
218	sub perl_inherit ($;$) {
219	my ($isa, $mod) = @_;
220	return '' unless @$isa;
221	$isa = array_uniq $isa;
222
223	if ($mod) {
224	perl_statement 'push ' . perl_var (type => '@',
225	local_name => 'ISA',
226	package => {full_name => $mod}) .
227	', ' . perl_list (@$isa);
228	} else {
229	perl_statement 'push our @ISA, ' . perl_list (@$isa);
230	}
231	}
232
233	sub perl_sub (%) {
234	my %opt = @_;
235	my $r = 'sub ';
236	$r .= $opt{name} . ' ' if $opt{name};
237	$r .= '(' . $opt{prototype} . ') ' if defined $opt{prototype};
238	$r .= "{\n";
239	$r .= $opt{code};
240	$r .= "}\n";
241	$r;
242	}
243
244	sub perl_cases (@) {
245	my $r = '';
246	while (my ($when, $code) = splice @_, 0, 2) {
247	$r .= $when ne 'else' ? qq<} elsif ($when) {\n$code\n>
248	: qq<} else {\n$code\n>;
249	}
250	$r =~ s/^\} els//;
251	$r .= qq<}\n> if $r;
252	$r = "\n" . $r if $r;
253	$r;
254	}
255
256	sub perl_var (%) {
257	my %opt = @_;
258	my $r = $opt{type} \|\| ''; # $, @, *, &, $# or empty
259	$r = $opt{scope} . ' ' . $r if $opt{scope}; # my, our or local
260	my $pack = ref $opt{package} ? $opt{package}->{full_name} : $opt{package};
261	$r .= $pack . '::' if $pack;
262	impl_err q<Local name of variable must be specified>, %opt
263	unless defined $opt{local_name};
264	$r .= $opt{local_name};
265	$r;
266	}
267
268	{
269	use re 'eval';
270	my $RegBlockContent;
271	$RegBlockContent = qr/(?>[^{}\\])(?>(?>[^{}\\]+\|\\.\|\{(??{$RegBlockContent})\}))/s;
272	sub perl_code ($;%);
273	sub perl_code ($;%) {
274	my ($s, %opt) = @_;
275	valid_err q<Uninitialized value in perl_code>,
276	node => $opt{node} unless defined $s;
277	$s =~ s[<Q:([^<>]+)>\|\b(null\|true\|false)\b][
278	my ($q, $l) = ($1, $2);
279	if (defined $q) {
280	if ($q =~ /\}/) {
281	valid_warn qq<Possible typo in the QName: "$q">;
282	}
283	perl_literal (expanded_uri ($q));
284	} else {
285	{true => 1, false => 0, null => 'undef'}->{$l};
286	}
287	]ge;
288	## TODO: Ensure Message::Util::Error imported if try.
289	## ISSUE: __FILE__ & __LINE__ will break if multiline substition happens.
290	$s =~ s{
291	\b__([A-Z]+)
292	(?:\{($RegBlockContent)\})?
293	__\b
294	}{
295	my ($name, $data) = ($1, $2);
296	my $r;
297	if ($name eq 'DEEP') { ## Deep Method Call
298	$r = 'do { local $Error::Depth = $Error::Depth + 1;' . perl_code ($data) .
299	'}';
300	} elsif ($name eq 'FILE' or $name eq 'LINE' or $name eq 'PACKAGE') {
301	$r = qq<__${name}__>;
302	} else {
303	valid_err qq<Preprocessing macro "$name" not supported>;
304	}
305	$r;
306	}goex;
307	$s;
308	}
309	}
310
311	{my $f = 0;
312	sub perl_code_source ($%) {
313	my ($s, %opt) = @_;
314	sprintf qq<\n#line %d "File <%s> Node <%s>"\n%s\n> .
315	qq<#line 1 "File <%s> Chunk #%d"\n>,
316	$opt{line} \|\| 1, $opt{file} \|\| '',
317	$opt{path} \|\| 'x:unknown ()', $s,
318	$opt{file} \|\| '', ++$f;
319	}}
320
321	sub perl_code_literal ($) {
322	my $s = shift;
323	bless \$s, '__code';
324	}
325
326	sub perl_literal ($) {
327	my $s = shift;
328	unless (defined $s) {
329	impl_warn q<Undefined value is passed to perl_literal ()>;
330	return q<undef>;
331	} elsif (ref $s eq 'ARRAY') {
332	return q<[> . perl_list (@$s) . q<]>;
333	} elsif (ref $s eq 'HASH') {
334	return q<{> . perl_list (%$s) . q<}>;
335	} elsif (ref $s eq 'CODE') {
336	impl_err q<CODE reference cannot be serialized>;
337	} elsif (ref $s eq '__code') {
338	return $$s;
339	} else {
340	## NOTE: Don't change quote char - perl_code depends this quote.
341	$s =~ s/(['\\])/\\$1/g;
342	return q<'> . $s . q<'>;
343	}
344	}
345
346	sub perl_list (@) {
347	join ', ', map perl_literal $_, @_;
348	}
349
350	sub perl_if ($$;$) {
351	my ($condition, $true, $false) = @_;
352	my $if = q<if>;
353	unless (defined $true) {
354	$if = q<unless>;
355	$true = $false;
356	$false = undef;
357	}
358	for ($true, $false) {
359	$_ = "\n" . $_ if $_ and /\A#\w+/;
360	}
361	my $r = qq<\n$if ($condition) {\n>.
362	qq< $true>.
363	qq<}>;
364	if (defined $false) {
365	$r .= qq< else {\n>.
366	qq< $false>.
367	qq<}>;
368	}
369	$r .= qq<\n>;
370	$r;
371	} # perl_if
372
373
374	sub pod_comment (@) {
375	(q<=begin comment>, @_, q<=end comment>);
376	}
377
378	sub pod_block (@) {
379	my @v = grep ((defined and length), @_);
380	join "\n\n", '', ($v[0] =~ /^=/ ? () : '=pod'), @v, '=cut', '';
381	}
382
383	sub pod_head ($$) {
384	my ($level, $s) = @_;
385	$s =~ s/\s+/ /g;
386	if ($level < 5) {
387	'=head' . $level . ' ' . $s; ## pod has only head1-head4.
388	} else {
389	'B<' . $s . '>';
390	}
391	}
392
393	sub pod_list ($@) {
394	my $m = shift;
395	('=over ' . $m, @_, '=back');
396	}
397
398	sub pod_item ($) {
399	my ($s) = @_;
400	valid_err q<Uninitialized value in pod_item> unless defined $s;
401	$s =~ s/\s+/ /g;
402	'=item ' . $s;
403	}
404
405	sub pod_pre ($) {
406	my $s = shift;
407	return '' unless defined $s;
408	$s =~ s/\n/\n /g;
409	' ' . $s;
410	}
411
412	sub pod_para ($) {
413	my $s = shift;
414	return '' unless defined $s;
415	$s =~ s/\n\s+/\n/g;
416	$s;
417	}
418
419	sub pod_paras ($) {
420	shift;
421	}
422
423	sub pod_cdata ($) {
424	my $s = shift;
425	$s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
426	$s;
427	}
428
429	sub pod_code ($) {
430	my $s = shift;
431	$s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
432	qq<C<$s>>;
433	}
434
435	sub pod_em ($) {
436	my $s = shift;
437	$s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
438	qq<I<$s>>;
439	}
440
441	sub pod_dfn ($) {
442	my $s = shift;
443	$s =~ s/([<>])/{'<' => 'E<lt>', '>' => 'E<gt>'}->{$1}/ge;
444	qq<I<$s>X<$s>>;
445	}
446
447	sub pod_char (%) {
448	my %opt = @_;
449	if ($opt{name}) {
450	if ($opt{name} eq 'copy') {
451	qq<E<169>>;
452	} else {
453	qq<E<$opt{name}>>;
454	}
455	} else {
456	impl_err q<Bad parameter for "pod_char">;
457	}
458	} # pod_char
459
460	sub pod_uri ($) {
461	my $uri = shift;
462	qq<E<lt>${uri}E<gt>>;
463	} # pod_uri
464
465	sub pod_mail ($) {
466	my $mail = shift;
467	qq<E<lt>${mail}E<gt>>;
468	} # pod_mail
469
470	sub pod_link (%) {
471	my %opt = @_;
472	if ($opt{label}) {
473	$opt{label} .= '\|';
474	} else {
475	$opt{label} = '';
476	}
477	if ($opt{section}) {
478	qq<L<$opt{label}/"$opt{section}">>;
479	} elsif ($opt{module}) {
480	qq<L<$opt{label}$opt{module}>>;
481	} else {
482	impl_err q<Bad parameter for "pod_link">;
483	}
484	}
485
486
487	sub muf_template ($) {
488	my $s = shift;
489	$s =~ s{<Q:([^<>]+)>}{ ## QName
490	expanded_uri ($1)
491	}ge;
492	$s;
493	}
494
495	sub section (@) {
496	my @r;
497	while (my ($t, $s) = splice @_, 0, 2) {
498	if ($t eq 'req' and (not defined $s or not length $s)) {
499	return ();
500	} elsif (defined $s and length $s) {
501	push @r, $s;
502	}
503	}
504	return @r;
505	}
506
507
508	sub rfc3339_date ($) {
509	my @time = gmtime shift;
510	sprintf q<%04d-%02d-%02dT%02d:%02d:%02d+00:00>,
511	$time[5] + 1900, $time[4] + 1, @time[3,2,1,0];
512	}
513
514	sub version_date ($) {
515	my @time = gmtime shift;
516	sprintf q<%04d%02d%02d.%02d%02d>,
517	$time[5] + 1900, $time[4] + 1, @time[3,2,1];
518	}
519
520	=back
521
522	=head1 LICENSE
523
524	Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
525
526	This program is free software; you can redistribute it and/or
527	modify it under the same terms as Perl itself.
528
529	=cut
530
531	1; # $Date: 2005/04/04 15:21:32 $