SuikaWiki/Plugin/WikiResource.wp2

#?SuikaWikiConfig/2.0

Plugin:
  @Name: WikiResource
  @Description:
    @@@: Wiki resource text support
    @@lang:en
  @License: %%Perl%%
  @Author:
    @@Name:
      @@@@: Wakaba
      @@@lang:ja
      @@@script:Latn
    @@Mail[list]: w@suika.fam.cx
  @Date.RCS:
    $Date: 2004/03/19 03:44:15 $
  @RequiredPlugin[list]:
    SuikaWikiConst09
  @Use:
    use Message::Util::Error;
    my $RESOURCE_CACHE;
    our $NestLevel;

PluginConst:
  @NS_XHTML1:
    http://www.w3.org/1999/xhtml

FormattingRule:
  @Category[list]:
    view
    view-resource
    page-link
    link-to-resource
    form-input
    form-template
  @Name: res
  @Description:
    @@@: Resource
    @@lang: en
  @Parameter:
    @@Name: name
    @@Type: CDATA
    @@Default: #REQUIRED
    @@Description:
      @@@@: Resource name
      @@@lang:en
  @Formatting:
    __ATTRTEXT:%name__;
    __FUNCPACK__->get (name => $p->{name},
                       wiki => $o->{wiki},
                       formatter_context => 'view_resource',
                       formatter_option => {param => $o,
                                            -parent => $p->{-parent}});

FormattingRule:
  @Category[list]:
    view
    view-resource
    page-link
    link-to-resource
    form-input
    form-template
  @Name: resource-as-plain-text
  @Description:
    @@@: Resource
    @@lang: en
  @Parameter:
    @@Name: name
    @@Type: CDATA
    @@Default: #REQUIRED
    @@Description:
      @@@@: Resource name
      @@@lang:en
  @Formatting:
    __ATTRTEXT:%name__;
    $p->{-parent}->append_text
           (__FUNCPACK__->get (name => $p->{name},
                               wiki => $o->{wiki}));

Function:
  @Name: logging_template_error
  @Description:
    @@@:
      Logging formatting-template-text error
    @@lang:en
  @Main:
    my (undef, $err, $wiki, %opt) = @_;
    my $error = {};
    my $dl = $error->{description}
           = new Message::Markup::XML::Node
               (type => '#element',
                namespace_uri => $NS_XHTML1,
                local_name => 'dl');
## TODO: Use resource
    $dl->append_new_node (type => '#element',
                          namespace_uri => $NS_XHTML1,
                          local_name => 'dt')
       ->append_text ('Resource name');
    $dl->append_new_node (type => '#element',
                          namespace_uri => $NS_XHTML1,
                          local_name => 'dd')
       ->append_text ($opt{resource_name});
    $dl->append_new_node (type => '#element',
                          namespace_uri => $NS_XHTML1,
                          local_name => 'dt')
       ->append_text ('Error condition');
    $dl->append_new_node (type => '#element',
                          namespace_uri => $NS_XHTML1,
                          local_name => 'dd')
       ->append_text ($err->text);
    $dl->append_new_node (type => '#element',
                          namespace_uri => $NS_XHTML1,
                          local_name => 'dt')
       ->append_text ('Formatting context');
    $dl->append_new_node (type => '#element',
                          namespace_uri => $NS_XHTML1,
                          local_name => 'dd')
       ->append_text (qq($err->{-formatter}->{-category_name}));

    push @{$wiki->{var}->{error}||=[]}, $error;

Function:
  @Name: get_text
  @Main:
    my (undef, %opt) = @_;
    __FUNCPACK__->get (%opt);
## TODO: Implements formatter.

Function:
  @Name: append_node
  @Main:
    my (undef, %opt) = @_;
    __FUNCPACK__->get (%opt, formatter_context => 'view_resource',
                             formatter_option => {param => $opt{param},
                                                  -parent => $opt{parent}});

Function:
  @Name: get_op
  @Description:
    @@@: Simple version of "get"
    @@lang: en
  @Main:
    my (undef, $name, $o, $parent, %opt) = @_;
    __FUNCPACK__->get (%opt, name => $name, o => $o, wiki => $o->{wiki},
                       formatter_context => 'view_resource',
                       formatter_option => {param => $o,
                                            -parent => $parent});

Function:
  @Name: get
  @Main:
    my (undef, %opt) = @_;
    local $NestLevel = $NestLevel + 1;
    if (10000 < $NestLevel) {
      SuikaWiki::Plugin->module_package ('Error')
 ## TODO:
                       ->report_error_simple
                           ($opt{wiki} || $opt{o}->{wiki},
                            'Condition' => 'Resource nesting too deep',
                            ResourceName => $opt{name},
                            -trace => 1);
      return defined $opt{default} ? $opt{default} : $opt{name};
    }
    

    my $text = __FUNCPACK__->temp_get_resource_text
                        (resource_ns => ($opt{o}->{wiki} || $opt{wiki})->name
                           ($opt{ns} || [qw/Wiki Resource/]),
                         name => $opt{name},
                         wiki => $opt{wiki});
    if (defined $text) {
      # 
    } elsif (defined $opt{default}) {
      $text = $opt{default};
    } else {
      $text = $opt{name};
    }
    
    return $text unless $opt{formatter_context};
    try {
      $text = SuikaWiki::Plugin->formatter ($opt{formatter_context})
                               ->replace ($text, %{$opt{formatter_option}});
    } catch Message::Util::Formatter::error with {
      my $err = shift;
      if ($err->{-formatter}->{-category_name} eq $opt{formatter_context}) {
        __FUNCPACK__->logging_template_error ($err,
                                              $err->{-option}->{param}->{wiki},
                                              resource_name => $opt{name});
        undef;
      } else {
        $err->throw;
      }
    };
    return $text;

Function:
  @Name: temp_get_resource_text
  @Main:
    my (undef, %opt) = @_;
    CORE::die "Buggy implementation: \$opt{wiki} required ".Carp::longmess()
      unless ref $opt{wiki};
    $opt{accept_language} ||= __FUNCPACK__->temp_get_accept_language (%opt);
    $opt{resource} ||= $RESOURCE_CACHE ||= {};
    my $v;
    my $SWC09;
    try {
      $SWC09 = SuikaWiki::Plugin->module_package ('SuikaWikiConst09');
    } catch SuikaWiki::Plugin::error with {
      my $err = shift;
      $err->raise unless $err->{-type} eq 'PLUGIN_NOT_FOUND';
    };
    for my $lang (sort {$opt{accept_language}->{$b} <=>
                        $opt{accept_language}->{$a}}
                  grep {$opt{accept_language}->{$_} != 0}
                  keys %{$opt{accept_language}}) {
      while (length $lang) {
        unless ($opt{accept_language}->{defined $opt{accept_language}->{$lang}
                                          ? $lang : '*'} == 0) {
          ## WikiPage defined resource text (SuikaWikiConst/0.9)
          if (not $opt{resource}->{$lang} and ref $opt{wiki}->{db} and $SWC09) {
            try {
              $v = $opt{wiki}->{db}->get (content => [@{$opt{resource_ns}}, $lang]);
            } catch SuikaWiki::DB::Util::Error with {
              my $err = shift;
              $err->throw if $err->{-type} eq 'ERROR_REPORTED';
              $v = undef;
            };
            $opt{resource}->{$lang} = {};
            $SWC09->text_to_hash (text => \$v,
                                             hash => $opt{resource}->{$lang});
          }
          $v = $opt{resource}->{$lang}->{$opt{name}};
          last if defined $v;
          ## WikiPlugin defined resource text (SuikaWiki 3 WikiPlugin)
          if (defined $SuikaWiki::Plugin::Resource::BaseResource->{$lang}->{''}->{$opt{name}}) {
            $v = $SuikaWiki::Plugin::Resource::BaseResource->{$lang}->{''}->{$opt{name}};
            last;
          }
        }
        $lang =~ s/[^+-]*$//; $lang =~ s/[+-]$//;
      }
      last if defined $v;
    } # Accepted languages
    if (defined $v) {
      return $v;
    } else {
      ## Plugin defined resource text or undef
      return $SuikaWiki::Plugin::Resource::BaseResource->{und}->{''}->{$opt{name}};
    }

Function:
  @Name: temp_get_language_resource_from_array
  @Main:
    my (undef, %opt) = @_;
    CORE::die "Buggy implementation: \$opt{o} required ".Carp::longmess()
      unless ref $opt{o};
    $opt{source} ||= [];
    if (@{$opt{source}} < 2) {
      return ($opt{source} || [])->[0];
    }
    $opt{accept_language} ||= __FUNCPACK__->temp_get_accept_language
                                              (wiki => $opt{o}->{wiki}, %opt);
    my $und;
    for my $lang (sort {$opt{accept_language}->{$b} <=>
                        $opt{accept_language}->{$a}}
                  grep {$opt{accept_language}->{$_} != 0}
                  keys %{$opt{accept_language}}) {
      while (length $lang) {
        unless ($opt{accept_language}->{defined $opt{accept_language}->{$lang}
                                          ? $lang : '*'} == 0) {
          for (@{$opt{source}}) {
            if ($_->[1] eq $lang) {
              return $_; ## TODO: Script support
            } elsif ($_->[1] eq 'und') {
              $und = $_;
            }
          }
        }
        $lang =~ s/[^+-]*$//; $lang =~ s/[+-]$//;
      }
    } # Accepted languages
    return $und || [];

Function:
  @Name: temp_get_accept_language
  @Main:
    my (undef, %opt) = @_;

    ## Accept language specification
    my $alang;
    if ($opt{wiki}->{input}) {
      $alang = $opt{wiki}->{input}->meta_variable ('HTTP_ACCEPT_LANGUAGE');
    }
    $alang ||= q<i-default;q=1.0,en;q=0.9,ja;q=0.8,*;q=0.001>;
    
    ## Old user agent support
    my %alang = (ja => 0.0002, en => 0.0001);
    if ($opt{wiki}->{var}->{client}->{user_agent_name} =~ m#^Mozilla/0\.#) {
            $alang{ja} = 0.00001;
    }
    
    ## Parse accept language specification
    my $i = 0.1;
    for (split /\s*,\s*/, $alang) {
      tr/\x09\x0A\x0D\x20//d;
            if (/((?:(?!;q=).)+)(?:;q="?([0-9.]+)"?)?/) {
              my $l = lc $1; $l =~ tr/\x22\x5C//d;
              $alang{$l} = (defined $2 ? $2 : 1.000)*1000;
              $alang{$l} += $i unless $alang{$l} == 0;
              $i -= 0.001;
            }
    }
    return \%alang;
1	wakaba	1.1	#?SuikaWikiConfig/2.0
2
3			Plugin:
4			@Name: WikiResource
5			@Description:
6			@@@: Wiki resource text support
7			@@lang:en
8	wakaba	1.5	@License: %%Perl%%
9	wakaba	1.1	@Author:
10			@@Name:
11			@@@@: Wakaba
12			@@@lang:ja
13			@@@script:Latn
14			@@Mail[list]: w@suika.fam.cx
15	wakaba	1.5	@Date.RCS:
16	wakaba	1.9	$Date: 2004/03/19 03:44:15 $
17	wakaba	1.3	@RequiredPlugin[list]:
18			SuikaWikiConst09
19	wakaba	1.2	@Use:
20			use Message::Util::Error;
21	wakaba	1.4	my $RESOURCE_CACHE;
22	wakaba	1.5	our $NestLevel;
23	wakaba	1.1
24			PluginConst:
25			@NS_XHTML1:
26			http://www.w3.org/1999/xhtml
27
28			FormattingRule:
29			@Category[list]:
30			view
31			view-resource
32			page-link
33	wakaba	1.3	link-to-resource
34	wakaba	1.1	form-input
35			form-template
36			@Name: res
37			@Description:
38			@@@: Resource
39			@@lang: en
40			@Parameter:
41			@@Name: name
42			@@Type: CDATA
43			@@Default: #REQUIRED
44			@@Description:
45			@@@@: Resource name
46			@@@lang:en
47			@Formatting:
48			__ATTRTEXT:%name__;
49	wakaba	1.3	__FUNCPACK__->get (name => $p->{name},
50			wiki => $o->{wiki},
51			formatter_context => 'view_resource',
52			formatter_option => {param => $o,
53			-parent => $p->{-parent}});
54	wakaba	1.1
55	wakaba	1.4	FormattingRule:
56			@Category[list]:
57			view
58			view-resource
59			page-link
60			link-to-resource
61			form-input
62			form-template
63			@Name: resource-as-plain-text
64			@Description:
65			@@@: Resource
66			@@lang: en
67			@Parameter:
68			@@Name: name
69			@@Type: CDATA
70			@@Default: #REQUIRED
71			@@Description:
72			@@@@: Resource name
73			@@@lang:en
74			@Formatting:
75			__ATTRTEXT:%name__;
76	wakaba	1.9	$p->{-parent}->append_text
77			(__FUNCPACK__->get (name => $p->{name},
78			wiki => $o->{wiki}));
79	wakaba	1.4
80	wakaba	1.2	Function:
81			@Name: logging_template_error
82			@Description:
83			@@@:
84			Logging formatting-template-text error
85			@@lang:en
86			@Main:
87			my (undef, $err, $wiki, %opt) = @_;
88			my $error = {};
89			my $dl = $error->{description}
90			= new Message::Markup::XML::Node
91			(type => '#element',
92			namespace_uri => $NS_XHTML1,
93			local_name => 'dl');
94			## TODO: Use resource
95			$dl->append_new_node (type => '#element',
96			namespace_uri => $NS_XHTML1,
97			local_name => 'dt')
98			->append_text ('Resource name');
99			$dl->append_new_node (type => '#element',
100			namespace_uri => $NS_XHTML1,
101			local_name => 'dd')
102			->append_text ($opt{resource_name});
103			$dl->append_new_node (type => '#element',
104			namespace_uri => $NS_XHTML1,
105			local_name => 'dt')
106			->append_text ('Error condition');
107			$dl->append_new_node (type => '#element',
108			namespace_uri => $NS_XHTML1,
109			local_name => 'dd')
110			->append_text ($err->text);
111			$dl->append_new_node (type => '#element',
112			namespace_uri => $NS_XHTML1,
113			local_name => 'dt')
114			->append_text ('Formatting context');
115			$dl->append_new_node (type => '#element',
116			namespace_uri => $NS_XHTML1,
117			local_name => 'dd')
118			->append_text (qq($err->{-formatter}->{-category_name}));
119
120			push @{$wiki->{var}->{error}\|\|=[]}, $error;
121	wakaba	1.3
122			Function:
123			@Name: get_text
124			@Main:
125			my (undef, %opt) = @_;
126			__FUNCPACK__->get (%opt);
127			## TODO: Implements formatter.
128
129			Function:
130			@Name: append_node
131			@Main:
132			my (undef, %opt) = @_;
133			__FUNCPACK__->get (%opt, formatter_context => 'view_resource',
134			formatter_option => {param => $opt{param},
135			-parent => $opt{parent}});
136
137			Function:
138	wakaba	1.5	@Name: get_op
139			@Description:
140			@@@: Simple version of "get"
141			@@lang: en
142			@Main:
143			my (undef, $name, $o, $parent, %opt) = @_;
144			__FUNCPACK__->get (%opt, name => $name, o => $o, wiki => $o->{wiki},
145			formatter_context => 'view_resource',
146			formatter_option => {param => $o,
147			-parent => $parent});
148
149			Function:
150	wakaba	1.3	@Name: get
151			@Main:
152			my (undef, %opt) = @_;
153	wakaba	1.5	local $NestLevel = $NestLevel + 1;
154	wakaba	1.9	if (10000 < $NestLevel) {
155	wakaba	1.5	SuikaWiki::Plugin->module_package ('Error')
156			## TODO:
157			->report_error_simple
158			($opt{wiki} \|\| $opt{o}->{wiki},
159			'Condition' => 'Resource nesting too deep',
160			ResourceName => $opt{name},
161			-trace => 1);
162			return defined $opt{default} ? $opt{default} : $opt{name};
163			}
164	wakaba	1.3
165
166
167			my $text = __FUNCPACK__->temp_get_resource_text
168	wakaba	1.8	(resource_ns => ($opt{o}->{wiki} \|\| $opt{wiki})->name
169			($opt{ns} \|\| [qw/Wiki Resource/]),
170			name => $opt{name},
171			wiki => $opt{wiki});
172	wakaba	1.3	if (defined $text) {
173			#
174	wakaba	1.5	} elsif (defined $opt{default}) {
175	wakaba	1.3	$text = $opt{default};
176			} else {
177			$text = $opt{name};
178			}
179
180			return $text unless $opt{formatter_context};
181			try {
182			$text = SuikaWiki::Plugin->formatter ($opt{formatter_context})
183			->replace ($text, %{$opt{formatter_option}});
184			} catch Message::Util::Formatter::error with {
185			my $err = shift;
186			if ($err->{-formatter}->{-category_name} eq $opt{formatter_context}) {
187			__FUNCPACK__->logging_template_error ($err,
188			$err->{-option}->{param}->{wiki},
189			resource_name => $opt{name});
190			undef;
191			} else {
192			$err->throw;
193			}
194			};
195			return $text;
196
197			Function:
198			@Name: temp_get_resource_text
199			@Main:
200			my (undef, %opt) = @_;
201	wakaba	1.4	CORE::die "Buggy implementation: \$opt{wiki} required ".Carp::longmess()
202			unless ref $opt{wiki};
203	wakaba	1.3	$opt{accept_language} \|\|= __FUNCPACK__->temp_get_accept_language (%opt);
204	wakaba	1.4	$opt{resource} \|\|= $RESOURCE_CACHE \|\|= {};
205	wakaba	1.3	my $v;
206	wakaba	1.7	my $SWC09;
207			try {
208			$SWC09 = SuikaWiki::Plugin->module_package ('SuikaWikiConst09');
209			} catch SuikaWiki::Plugin::error with {
210			my $err = shift;
211			$err->raise unless $err->{-type} eq 'PLUGIN_NOT_FOUND';
212			};
213	wakaba	1.3	for my $lang (sort {$opt{accept_language}->{$b} <=>
214			$opt{accept_language}->{$a}}
215			grep {$opt{accept_language}->{$_} != 0}
216			keys %{$opt{accept_language}}) {
217			while (length $lang) {
218			unless ($opt{accept_language}->{defined $opt{accept_language}->{$lang}
219			? $lang : '*'} == 0) {
220			## WikiPage defined resource text (SuikaWikiConst/0.9)
221	wakaba	1.7	if (not $opt{resource}->{$lang} and ref $opt{wiki}->{db} and $SWC09) {
222	wakaba	1.4	try {
223			$v = $opt{wiki}->{db}->get (content => [@{$opt{resource_ns}}, $lang]);
224			} catch SuikaWiki::DB::Util::Error with {
225	wakaba	1.6	my $err = shift;
226			$err->throw if $err->{-type} eq 'ERROR_REPORTED';
227	wakaba	1.4	$v = undef;
228			};
229	wakaba	1.3	$opt{resource}->{$lang} = {};
230	wakaba	1.7	$SWC09->text_to_hash (text => \$v,
231	wakaba	1.3	hash => $opt{resource}->{$lang});
232			}
233			$v = $opt{resource}->{$lang}->{$opt{name}};
234			last if defined $v;
235			## WikiPlugin defined resource text (SuikaWiki 3 WikiPlugin)
236			if (defined $SuikaWiki::Plugin::Resource::BaseResource->{$lang}->{''}->{$opt{name}}) {
237			$v = $SuikaWiki::Plugin::Resource::BaseResource->{$lang}->{''}->{$opt{name}};
238			last;
239			}
240			}
241			$lang =~ s/[^+-]*$//; $lang =~ s/[+-]$//;
242			}
243			last if defined $v;
244			} # Accepted languages
245			if (defined $v) {
246			return $v;
247			} else {
248			## Plugin defined resource text or undef
249			return $SuikaWiki::Plugin::Resource::BaseResource->{und}->{''}->{$opt{name}};
250			}
251	wakaba	1.5
252			Function:
253			@Name: temp_get_language_resource_from_array
254			@Main:
255			my (undef, %opt) = @_;
256			CORE::die "Buggy implementation: \$opt{o} required ".Carp::longmess()
257			unless ref $opt{o};
258			$opt{source} \|\|= [];
259			if (@{$opt{source}} < 2) {
260			return ($opt{source} \|\| [])->[0];
261			}
262			$opt{accept_language} \|\|= __FUNCPACK__->temp_get_accept_language
263			(wiki => $opt{o}->{wiki}, %opt);
264			my $und;
265			for my $lang (sort {$opt{accept_language}->{$b} <=>
266			$opt{accept_language}->{$a}}
267			grep {$opt{accept_language}->{$_} != 0}
268			keys %{$opt{accept_language}}) {
269			while (length $lang) {
270			unless ($opt{accept_language}->{defined $opt{accept_language}->{$lang}
271			? $lang : '*'} == 0) {
272			for (@{$opt{source}}) {
273			if ($_->[1] eq $lang) {
274			return $_; ## TODO: Script support
275			} elsif ($_->[1] eq 'und') {
276			$und = $_;
277			}
278			}
279			}
280			$lang =~ s/[^+-]*$//; $lang =~ s/[+-]$//;
281			}
282			} # Accepted languages
283			return $und \|\| [];
284
285	wakaba	1.3	Function:
286			@Name: temp_get_accept_language
287			@Main:
288			my (undef, %opt) = @_;
289	wakaba	1.6
290			## Accept language specification
291			my $alang;
292			if ($opt{wiki}->{input}) {
293			$alang = $opt{wiki}->{input}->meta_variable ('HTTP_ACCEPT_LANGUAGE');
294			}
295			$alang \|\|= q<i-default;q=1.0,en;q=0.9,ja;q=0.8,*;q=0.001>;
296
297			## Old user agent support
298	wakaba	1.3	my %alang = (ja => 0.0002, en => 0.0001);
299			if ($opt{wiki}->{var}->{client}->{user_agent_name} =~ m#^Mozilla/0\.#) {
300			$alang{ja} = 0.00001;
301			}
302	wakaba	1.6
303			## Parse accept language specification
304			my $i = 0.1;
305			for (split /\s,\s/, $alang) {
306			tr/\x09\x0A\x0D\x20//d;
307	wakaba	1.3	if (/((?:(?!;q=).)+)(?:;q="?([0-9.]+)"?)?/) {
308			my $l = lc $1; $l =~ tr/\x22\x5C//d;
309			$alang{$l} = (defined $2 ? $2 : 1.000)*1000;
310			$alang{$l} += $i unless $alang{$l} == 0;
311			$i -= 0.001;
312			}
313	wakaba	1.6	}
314	wakaba	1.3	return \%alang;