archive/oddmuse
2
0
Fork 0
forked from github/kensanata.oddmuse
Code Pull Requests Activity
Files
9d0ff86a440f7e8a765cbe782fc98e2dee94de2d
oddmuse/modules/relation.pl

186 lines
6.1 KiB
Perl
Raw Normal View History

New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
# Copyright (C) 2008 Andreas Hofmann
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
Changed nearly all modules from GPLv2 to GPLv3 There were some modules that did not offer "or (at your option) any later version" in their license and these had to be left alone. This should solve the incorrect FSF address issue #4 on GitHub.
2016-08-16 14:59:13 +02:00
# the Free Software Foundation; either version 3 of the License, or
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
Changed nearly all modules from GPLv2 to GPLv3 There were some modules that did not offer "or (at your option) any later version" in their license and these had to be left alone. This should solve the incorrect FSF address issue #4 on GitHub.
2016-08-16 14:59:13 +02:00
# along with this program. If not, see <http://www.gnu.org/licenses/>.
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
"use strict;" in modules (some modules have problems)
2015-03-27 03:01:01 +02:00
use strict;
use v5.10 everywhere + enabled test in meta.t
2015-08-18 10:48:03 +02:00
use v5.10;
"use strict;" in modules (some modules have problems)
2015-03-27 03:01:01 +02:00
Fixed typo in AddModuleDescription sub name
2014-08-21 22:23:23 +02:00
AddModuleDescription('relation.pl', 'Relation Extension');
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
No more "use vars"!
2015-04-10 13:31:28 +03:00
our ($q, %Action, $OpenPageName, @MyRules, $DataDir);
our (@RelationLinking, $RelationPassedFlag);
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
push(@MyRules, \&RelationRule);
No more masking of earlier declarations
2015-05-02 03:44:07 +03:00
$RelationPassedFlag = 0;
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
my $referencefile = "References.txt";
my $dummy = RelationRead();
sub RelationRead {
Whitespace.
2008-09-26 23:02:28 +00:00
# return scalar(@RelationLinking) if (scalar(@RelationLinking));
Moving modules from utf8::encode to encode_utf8
2016-06-22 15:37:04 +02:00
open (my $RRR, '<', encode_utf8("$DataDir/$referencefile")) || return(0);
No more two-arg open
2015-05-02 03:19:25 +03:00
while (<$RRR>) {
Whitespace.
2008-09-26 23:02:28 +00:00
chomp;
my ($a,$b,$c) = split(';');
# print "<!--- a,b,c=<$a,$b,$c> ---!>\n";
push @RelationLinking, [$a, $b, $c];
};
No more two-arg open
2015-05-02 03:19:25 +03:00
close($RRR);
Whitespace.
2008-09-26 23:02:28 +00:00
return (scalar(@RelationLinking));
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
}
sub RelationRule {
No more /o, modifiers sorted alphabetically
2015-08-23 21:22:12 +03:00
if (m/\G((forward@@|backward@@|forward@|backward@):([_A-Za-z0-9 ]+?);)/cg) {
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
Dirty($1);
my $rememberpos = pos;
my $fwbw =$2;
my $rel=$3;
my $rtext = '';
my $rhead;
$RelationPassedFlag++;
my @result;
if ( substr($fwbw,0,7) eq 'forward' ) {
Whitespace.
2008-09-26 23:02:28 +00:00
@result = map { $_->[2] } grep { $_->[0] eq $OpenPageName and $_->[1] eq $rel } @RelationLinking;
$rhead = "<h3>".NormalToFree($OpenPageName)." $rel:</h3>\n";
}
else{
@result = map { $_->[0] } grep { $_->[2] eq $OpenPageName and $_->[1] eq $rel } @RelationLinking;
$rhead = "<h3>$rel ".NormalToFree($OpenPageName).":</h3>\n";
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
}
if (scalar(@result) == 0 ) {
Whitespace.
2008-09-26 23:02:28 +00:00
if (substr($fwbw,-2) eq '@@') {
$rtext = "<!--- RelationRule hits: <$fwbw> <$rel> hiding empty ---!>\n"
}
else {
$rtext = "$rhead<ul><li>-no relation-</li></ul>\n";
}
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
}
Whitespace.
2008-09-26 23:02:28 +00:00
else {
$rtext = $rhead."<ul>\n";
foreach my $LLL (@result) {
$rtext .= "<li>" . GetPageOrEditLink($LLL,$LLL) . "</li>\n";
};
$rtext .= "</ul>\n";
};
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
pos = $rememberpos;
return $rtext;
}
'return undef' changed to 'return' This command was used: find . -type f -print0 | xargs -0 sed -i 's/return undef/return/g' The idea behind this commit is described on http://oddmuse.org/wiki/Refactoring page. In short: 'return undef' returns (undef) in list context (a list with one element), which is wrong.
2015-02-27 12:10:18 +02:00
return;
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
}
No more "*Sub = *NewSub", \&NewSub used instead. (Partial progress)
2015-04-11 23:41:33 +03:00
*OldRelationPrintFooter = \&PrintFooter;
*PrintFooter = \&RelationPrintFooter;
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
sub RelationPrintFooter {
my @params = @_;
if ($RelationPassedFlag > 0) {
Whitespace.
2008-09-26 23:02:28 +00:00
print "<div class='footnotes'>\n";
# print "<a href='$OpenPageName?action=checkrelates'>CheckRelations</a><br />\n";
"use strict;" in modules (some modules have problems)
2015-03-27 03:01:01 +02:00
print ScriptLink('action=checkrelates;id='.$OpenPageName, 'CheckRelations', 'index');
Whitespace.
2008-09-26 23:02:28 +00:00
print "</div>\n";
};
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
OldRelationPrintFooter(@params);
Whitespace.
2008-09-26 23:02:28 +00:00
};
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
$Action{'checkrelates'} = sub {
Whitespace.
2008-09-26 23:02:28 +00:00
my $id = shift;
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
Whitespace.
2008-09-26 23:02:28 +00:00
my @result = @RelationLinking;
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
Whitespace.
2008-09-26 23:02:28 +00:00
print $q->header;
print "<html><head><title>Edit Relations</title></head><body>\n";
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
Whitespace.
2008-09-26 23:02:28 +00:00
print "<!--- 1 id=$id --->\n";
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
Whitespace.
2008-09-26 23:02:28 +00:00
print "<h3>Relations of $id (to be deleted)</h3>\n";
print "<form action='".ScriptUrl("action=updaterelates")."' method='post'>\n";
my $count = -1;
foreach my $r (@result) {
$count++;
next if ($id ne $r->[0] and $id ne $r->[2]);
print "<input type='checkbox' name='delete$count' value='$count' unchecked >$r->[0] -> $r->[1] -> $r->[2]<br />\n";
};
print "<h3>New Relation of $id (to be created)</h3>\n";
print "$id -> <input name='newrelationto' type='text' size='30' maxlength='30'> -> <input name='newtargetto' type='text' size='30' maxlength='30'><br />\n";
print "<h3>New Relation from $id (to be created)</h3>\n";
print "<input name='newsourcefrom' type='text' size='30' maxlength='30'> -> <input name='newrelationfrom' type='text' size='30' maxlength='30'> -> $id<br />\n";
print "<input type=\"hidden\" name=\"id\" value=\"$id\" /><br />\n";
print "<input type='submit' name='action' value='updaterelates' />&nbsp;\n";
print "</form>\n";
print "</body></html>\n";
Added semicolons back in.
2008-09-26 23:00:27 +00:00
};
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
$Action{'updaterelates'} = sub {
my $id = shift;
print $q->header;
print "<html><head><title>Relations</title></head><body>\n";
my %h = $q->Vars;
print "<h3>Relations of $id</h3>";
my $newrelationto = undef;
my $newtargetto = undef;
my $newrelationfrom = undef;
my $newsourcefrom = undef;
foreach my $r (keys %h) {
Whitespace.
2008-09-26 23:02:28 +00:00
if ( $r =~ m/^delete([0-9]+)/ ) {
my $n = $1;
my $s = $h{$r};
print "delete: ". $RelationLinking[$n]->[0]." -> ". $RelationLinking[$n]->[1]." -> " . $RelationLinking[$n]->[2]."<br />\n";
$RelationLinking[$n] = undef;
}
elsif ( $r eq 'newtargetto') {
$newtargetto = $h{$r};
}
elsif ( $r eq 'newrelationto') {
$newrelationto = $h{$r};
}
elsif ( $r eq 'newsourcefrom') {
$newsourcefrom = $h{$r};
}
elsif ( $r eq 'newrelationfrom') {
$newrelationfrom = $h{$r};
}
else {
my $s = $h{$r};
print "other: $r -> $s<br />\n" unless ($r eq 'action' or $r eq 'id');
};
};
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
if (defined($newrelationto) and defined($newtargetto) and $newrelationto ne '' and $newtargetto ne '') {
Whitespace.
2008-09-26 23:02:28 +00:00
print "new: $id -> $newrelationto -> $newtargetto<br />\n";
push @RelationLinking, [$id, $newrelationto, FreeToNormal($newtargetto)];
}
else {
print "no new target<br />\n";
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
}
if (defined($newrelationfrom) and defined($newsourcefrom) and $newrelationfrom ne '' and $newsourcefrom ne '') {
Whitespace.
2008-09-26 23:02:28 +00:00
print "new: $newsourcefrom -> $newrelationfrom -> $id<br />\n";
push @RelationLinking, [FreeToNormal($newsourcefrom), $newrelationfrom, $id];
}
else {
print "no new source<br />\n";
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
}
Moving modules from utf8::encode to encode_utf8
2016-06-22 15:37:04 +02:00
open (my $RRR, '>', encode_utf8("$DataDir/$referencefile"));
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
print "<br />\n";
foreach my $t (@RelationLinking) {
Whitespace.
2008-09-26 23:02:28 +00:00
next unless (defined($t));
# print "trace:". $t->[0] .";". $t->[1].";". $t->[2] ."<br />\n";
No more two-arg open
2015-05-02 03:19:25 +03:00
print $RRR $t->[0] .";". $t->[1].";". $t->[2] ."\n";
Whitespace.
2008-09-26 23:02:28 +00:00
};
No more two-arg open
2015-05-02 03:19:25 +03:00
close($RRR);
New file by Andreas Hofmann
2008-09-26 22:59:31 +00:00
print ScriptLink('id='.$id, $id, 'index');
print "</body></html>\n";
Added semicolons back in.
2008-09-26 23:00:27 +00:00
};
Whitespace.
2008-09-26 23:02:28 +00:00
1;
Copy Permalink