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