simile/svn/index.cgi

#!/usr/bin/perl -w

# svn2js.pl
#
# 10/05/08 16:15:38 CEST Dobrica Pavlinusic <dpavlin@rot13.org>

use strict;
use XML::Simple;
use Data::Dump qw/dump/;
use JSON;
use CGI;
use File::Slurp;

my $debug = $ENV{'DEBUG'} || 0;

my $config_path = $0;
$config_path =~ s/.cgi/.js/;
my $config = from_json( read_file( $config_path ) );
my $repository_dir = $config->{repository_dir} || die "no repository_dir in $config_path";
my $svnweb = $config->{svnweb} || die "no svnweb in $config_path";
die "no js URLs to Exhibit API and/or plugins" unless $config->{js};

my $limit = 1000;

# for older JSON
#sub encode_json { objToJson( @_ ) }

sub path_strip {
        my $path = shift;
#       $path =~ $strip_branch;
        return $path;
}

opendir(my $dir, $repository_dir) || die "can't open $repository_dir: $!";
my @repositories = sort grep { -f "$repository_dir/$_/format" } readdir($dir);
closedir($dir);

our $q = CGI->new;
my $repository = $q->param('repository');
$repository = (grep { m/^\Q$repository\E$/ } @repositories )[0] if $repository;

warn "q = ",dump( $q );
warn "# limit: ", $q->param('limit');

sub select_repository {
        my $onChange = qq{document.getElementById('current_repository').submit();};
        # we want to activete javascript magic refresh after we hit submit for the first time, and not always
        $onChange = '' unless $q->param('did_submit');
        return (
                $q->start_form( -name => 'current_repository', -id => 'current_repository', -method => 'post' ),
                "From repository ",
                $q->param('did_submit') ?
                        $q->popup_menu( -name => 'repository', -values => [ @repositories ], -onChange => $onChange ) :
                        $q->radio_group( -name => 'repository', -values => [ @repositories ], -onChange => $onChange ), # , -linebreak => 'true' ),
                " show ",
                $q->popup_menu( -name => 'limit', -values => [ qw/100 500 1000 5000 10000/ ], -onChange => $onChange ),
                " revisions and ",
                $q->checkbox(-name=>'path', -checked=>1, -value=>'ON', -label=>'path modifications', -onChange => $onChange ),
                " ",
                $q->submit(-value=>'in Exhibit'),
                $q->hidden(-name=>'did_submit', -value=>1),
                $q->end_form
        );
}

if ( ! $repository ) {
        print $q->header,$q->start_html("Select repository"), select_repository;
        exit;
} elsif ( ! $q->param('json') ) {
        $repository ||= 'Select repository';
        print $q->header, qq|
<html>
<head>
<title>$repository -- Exhibit SVN exhibit facet browsing</title>

           <link rel="exhibit/data"
    type="application/json" 
    href="|, $q->url( -query => 1 ), qq|&json=1" />

|, join("\n", map { qq|<script src="$_" type="text/javascript"></script>| } @{ $config->{js} } ), qq|

</head>
<body>
<div style="float: right">
<a href="http://stud05.technikum-wien.at/~tw05n126/exhibit/log/log.html">based on</a>,
<a href="http://simile.mit.edu/exhibit/">exhibit</a></div>
|, select_repository, qq|
<table width="100%" style="font-size: 0.8em">
    <tr valign="top">
        <td rowspan="2" width="25%">
          <div ex:role="facet" ex:facetClass="TextSearch" ex:facetLabel="Search"></div>
        
            <div ex:role="facet" ex:expression=".author" ex:facetLabel="Author"
                ex:sortMode="count"></div>
|, $q->param('path') ?
qq|
            <div ex:role="facet" ex:expression=".action" ex:facetLabel="Action"
                ex:sortMode="count" ex:scroll="false"></div>
| : '',
qq|
            <div ex:role="facet" ex:expression=".revision" ex:facetClass="NumericRange"
                ex:interval="20" ex:scroll="true"></div>
|, $q->param('path') ?
qq|
            <div ex:role="facet" ex:expression=".path" ex:facetLabel="Path by Count"
                ex:sortMode="count"></div>
| : '',
qq|
        </td>
        <td>
        
            <div ex:role="facet" ex:expression=".path" ex:facetLabel="Path by Name"
                ex:sortMode="value"></div>
        </td>
    </tr>
    <tr valign="top">
        <td ex:role="viewPanel">

            <div ex:role="view" ex:viewClass="Timeline" ex:start=".date"
                ex:colorKey=".author" 
                ex:topBandUnit="week" ex:topBandPixelsPerUnit="200"
                ex:bottomBandUnit="month" ex:bottomBandPixelsPerUnit="25"
                ex:timelineHeight="550" />
            
            <div ex:role="view" ex:viewClass="Tabular"
                ex:columns=".revision, .author, .date, .PATH, .action, .copyfrom-path, .copyfrom-rev, .msg" 
                />
        </td>

    </tr>
</table>

</body>
</html>
        |;
        exit;
}

my $json = {
        properties => {
                revision => {
                        valueType => "number",
                },
                'google-code-svn-link' => {
                        valueType => "url"
                }
        },
        items => [],
};

my $log;
{
        my $cmd = "svn log --xml --stop-on-copy -v --limit " . ( $q->param('limit') || $limit ) . " file://$repository_dir/$repository";
        warn "cmd: $cmd\n";
        open( my $log_fh, '-|', $cmd) || die "can't read svn log: $!";
        local $/ = undef;
        $log = <$log_fh>;
        close( $log_fh );
}

my $xml = XMLin($log, ForceArray => [ 'logentry', 'path' ]);

warn dump( $xml ) if $debug;

foreach my $e (@{$xml->{'logentry'}}) {

        foreach my $p (@{$e->{'paths'}->{'path'}}) {
                my $path = delete( $p->{'content'} );
                my $label = $e->{'revision'} . ' - ' . path_strip( $path );
                my $item = {
                        type => 'Item',
                        id => $label,
                        label => $label,
                        uri => sprintf($svnweb, $repository, $e->{'revision'}),
                        path_full => $path,
                        path => path_strip( $path ),
                };

                $item->{$_} = $p->{$_} foreach grep { ! defined $item->{$_} } keys %$p;
                $item->{$_} = $e->{$_} foreach grep { ! defined $item->{$_} && ! /^(paths)$/ } keys %$e;

                warn dump( $item ) if $debug;

                push @{ $json->{items} }, $item;

                last if ! $q->param('path');
        }

}

print qq|Content-type: application/json\n\r\n\r|, encode_json( $json );

1	dpavlin	14	#!/usr/bin/perl -w
2
3			# svn2js.pl
4			#
5			# 10/05/08 16:15:38 CEST Dobrica Pavlinusic <dpavlin@rot13.org>
6
7			use strict;
8			use XML::Simple;
9			use Data::Dump qw/dump/;
10			use JSON;
11	dpavlin	16	use CGI;
12	dpavlin	36	use File::Slurp;
13	dpavlin	14
14	dpavlin	17	my $debug = $ENV{'DEBUG'} \|\| 0;
15	dpavlin	14
16	dpavlin	36	my $config_path = $0;
17			$config_path =~ s/.cgi/.js/;
18			my $config = from_json( read_file( $config_path ) );
19			my $repository_dir = $config->{repository_dir} \|\| die "no repository_dir in $config_path";
20			my $svnweb = $config->{svnweb} \|\| die "no svnweb in $config_path";
21	dpavlin	44	die "no js URLs to Exhibit API and/or plugins" unless $config->{js};
22	dpavlin	36
23	dpavlin	30	my $limit = 1000;
24	dpavlin	14
25	dpavlin	15	# for older JSON
26	dpavlin	16	#sub encode_json { objToJson( @_ ) }
27	dpavlin	15
28			sub path_strip {
29			my $path = shift;
30	dpavlin	30	# $path =~ $strip_branch;
31	dpavlin	15	return $path;
32			}
33
34	dpavlin	16	opendir(my $dir, $repository_dir) \|\| die "can't open $repository_dir: $!";
35			my @repositories = sort grep { -f "$repository_dir/$_/format" } readdir($dir);
36			closedir($dir);
37
38			our $q = CGI->new;
39			my $repository = $q->param('repository');
40	dpavlin	30	$repository = (grep { m/^\Q$repository\E$/ } @repositories )[0] if $repository;
41	dpavlin	16
42	dpavlin	30	warn "q = ",dump( $q );
43			warn "# limit: ", $q->param('limit');
44
45	dpavlin	16	sub select_repository {
46	dpavlin	30	my $onChange = qq{document.getElementById('current_repository').submit();};
47	dpavlin	43	# we want to activete javascript magic refresh after we hit submit for the first time, and not always
48			$onChange = '' unless $q->param('did_submit');
49	dpavlin	30	return (
50			$q->start_form( -name => 'current_repository', -id => 'current_repository', -method => 'post' ),
51			"From repository ",
52	dpavlin	46	$q->param('did_submit') ?
53			$q->popup_menu( -name => 'repository', -values => [ @repositories ], -onChange => $onChange ) :
54			$q->radio_group( -name => 'repository', -values => [ @repositories ], -onChange => $onChange ), # , -linebreak => 'true' ),
55	dpavlin	30	" show ",
56			$q->popup_menu( -name => 'limit', -values => [ qw/100 500 1000 5000 10000/ ], -onChange => $onChange ),
57	dpavlin	43	" revisions and ",
58	dpavlin	30	$q->checkbox(-name=>'path', -checked=>1, -value=>'ON', -label=>'path modifications', -onChange => $onChange ),
59	dpavlin	43	" ",
60	dpavlin	47	$q->submit(-value=>'in Exhibit'),
61			$q->hidden(-name=>'did_submit', -value=>1),
62	dpavlin	30	$q->end_form
63			);
64	dpavlin	16	}
65
66			if ( ! $repository ) {
67			print $q->header,$q->start_html("Select repository"), select_repository;
68			exit;
69			} elsif ( ! $q->param('json') ) {
70			$repository \|\|= 'Select repository';
71			print $q->header, qq\|
72			<html>
73			<head>
74			<title>$repository -- Exhibit SVN exhibit facet browsing</title>
75
76			<link rel="exhibit/data"
77			type="application/json"
78	dpavlin	30	href="\|, $q->url( -query => 1 ), qq\|&json=1" />
79	dpavlin	16
80	dpavlin	44	\|, join("\n", map { qq\|<script src="$_" type="text/javascript"></script>\| } @{ $config->{js} } ), qq\|
81	dpavlin	16
82			</head>
83			<body>
84			<div style="float: right">
85			<a href="http://stud05.technikum-wien.at/~tw05n126/exhibit/log/log.html">based on</a>,
86			<a href="http://simile.mit.edu/exhibit/">exhibit</a></div>
87			\|, select_repository, qq\|
88			<table width="100%" style="font-size: 0.8em">
89			<tr valign="top">
90			<td rowspan="2" width="25%">
91			<div ex:role="facet" ex:facetClass="TextSearch" ex:facetLabel="Search"></div>
92
93			<div ex:role="facet" ex:expression=".author" ex:facetLabel="Author"
94			ex:sortMode="count"></div>
95	dpavlin	30	\|, $q->param('path') ?
96			qq\|
97	dpavlin	16	<div ex:role="facet" ex:expression=".action" ex:facetLabel="Action"
98			ex:sortMode="count" ex:scroll="false"></div>
99	dpavlin	30	\| : '',
100			qq\|
101	dpavlin	16	<div ex:role="facet" ex:expression=".revision" ex:facetClass="NumericRange"
102	dpavlin	30	ex:interval="20" ex:scroll="true"></div>
103			\|, $q->param('path') ?
104			qq\|
105	dpavlin	16	<div ex:role="facet" ex:expression=".path" ex:facetLabel="Path by Count"
106			ex:sortMode="count"></div>
107	dpavlin	30	\| : '',
108			qq\|
109	dpavlin	16	</td>
110			<td>
111
112			<div ex:role="facet" ex:expression=".path" ex:facetLabel="Path by Name"
113			ex:sortMode="value"></div>
114			</td>
115			</tr>
116			<tr valign="top">
117			<td ex:role="viewPanel">
118
119			<div ex:role="view" ex:viewClass="Timeline" ex:start=".date"
120			ex:colorKey=".author"
121			ex:topBandUnit="week" ex:topBandPixelsPerUnit="200"
122			ex:bottomBandUnit="month" ex:bottomBandPixelsPerUnit="25"
123	dpavlin	30	ex:timelineHeight="550" />
124	dpavlin	16
125			<div ex:role="view" ex:viewClass="Tabular"
126	dpavlin	30	ex:columns=".revision, .author, .date, .PATH, .action, .copyfrom-path, .copyfrom-rev, .msg"
127	dpavlin	16	/>
128			</td>
129
130			</tr>
131			</table>
132
133			</body>
134			</html>
135			\|;
136			exit;
137			}
138
139	dpavlin	14	my $json = {
140			properties => {
141			revision => {
142			valueType => "number",
143			},
144			'google-code-svn-link' => {
145			valueType => "url"
146			}
147			},
148			items => [],
149			};
150
151			my $log;
152			{
153	dpavlin	30	my $cmd = "svn log --xml --stop-on-copy -v --limit " . ( $q->param('limit') \|\| $limit ) . " file://$repository_dir/$repository";
154			warn "cmd: $cmd\n";
155			open( my $log_fh, '-\|', $cmd) \|\| die "can't read svn log: $!";
156	dpavlin	14	local $/ = undef;
157			$log = <$log_fh>;
158			close( $log_fh );
159			}
160
161			my $xml = XMLin($log, ForceArray => [ 'logentry', 'path' ]);
162
163			warn dump( $xml ) if $debug;
164
165			foreach my $e (@{$xml->{'logentry'}}) {
166
167			foreach my $p (@{$e->{'paths'}->{'path'}}) {
168	dpavlin	15	my $path = delete( $p->{'content'} );
169			my $label = $e->{'revision'} . ' - ' . path_strip( $path );
170	dpavlin	14	my $item = {
171			type => 'Item',
172			id => $label,
173			label => $label,
174	dpavlin	16	uri => sprintf($svnweb, $repository, $e->{'revision'}),
175	dpavlin	15	path_full => $path,
176			path => path_strip( $path ),
177	dpavlin	14	};
178
179	dpavlin	15	$item->{$_} = $p->{$_} foreach grep { ! defined $item->{$_} } keys %$p;
180			$item->{$_} = $e->{$_} foreach grep { ! defined $item->{$_} && ! /^(paths)$/ } keys %$e;
181	dpavlin	14
182			warn dump( $item ) if $debug;
183
184			push @{ $json->{items} }, $item;
185
186	dpavlin	30	last if ! $q->param('path');
187	dpavlin	14	}
188
189			}
190
191			print qq\|Content-type: application/json\n\r\n\r\|, encode_json( $json );
192