-
[opensuse:license_o_o.git] / index.cgi
1 #!/usr/bin/perl -w
2 #
3 # 2009-09-19, jw
4 # 2009-09-22, jw - V0.2 overlib added and wizard_add_popup(), wizard_add() done.
5 #
6 # This requires perl-RPM-License from home:jnweiger:perl 
7 #      http://svn.berlios.de/wsvn/opensuse/trunk/tools/RPM-License
8 #
9 # The sqlite database only accessed if $lic_name_cache needs an update.
10
11 use Data::Dumper;
12 use CGI::Carp 'fatalsToBrowser';
13
14 use CGI;
15 my $q = new CGI;
16 print $q->header;
17
18 my $wizard =  $q->param('w') || 0;      # populate the license wizard
19 my $details =  $q->param('d');  # show all the details
20 my $lic_input =  $q->param('q');  # what he wants us to query
21 $q->{p} = $q->Vars;             # for self_url
22
23 ## we support non-proper query strings too.
24 ## ?q=GPLv2
25 ## ?GPL
26 if (defined($ENV{QUERY_STRING}) and $ENV{QUERY_STRING} !~ m{=})
27   {
28     $lic_input = $ENV{QUERY_STRING};
29     # FIXME: remove URLescaping
30     $lic_input =~ s{%20}{ }g;
31   }
32
33 my $now = scalar localtime;
34
35 use lib '/home/jw/lib/perl';
36 use RPM::License;
37 my $o = new RPM::License 'data/license_map.csv';
38 my $lic_name_sqlite =         '/home/jw/lib/ldig/sqlite/lic_name.sqlite';
39 my $lic_name_cache = 'data/tmp/lic_name_cache';
40
41 my $dbh = DBI->connect("dbi:SQLite:dbname=$lic_name_sqlite","","") or carp "DBI-connect($lic_name_sqlite) failed: $!";
42
43
44 my $stmt = 'SELECT n.id,n.name,n.url,n.url_ext,
45                 a28.value as fullname,
46                 a34.value as url_1,
47                 a35.value as url_2,
48                 a4.value as dfsg_free,
49                 a5.value as osi_approved 
50                   from lic_name n left join 
51                        lic_name_attr a28 on a28.lic_name_id = n.id left join 
52                        lic_name_attr a34 on a34.lic_name_id = n.id left join 
53                        lic_name_attr a35 on a35.lic_name_id = n.id left join 
54                        lic_name_attr a4 on a4.lic_name_id = n.id left join 
55                        lic_name_attr a5 on a5.lic_name_id = n.id 
56                   where a5.lic_name_attr_id = 5 and 
57                         a4.lic_name_attr_id = 4 and 
58                         a28.lic_name_attr_id = 28 and
59                         a34.lic_name_attr_id = 34 and
60                         a35.lic_name_attr_id = 35 and
61                         not n.obsolete';
62
63
64
65 if (! -f $lic_name_cache or -M $lic_name_cache > -M $lic_name_sqlite)
66   {
67     my $lic_name = $dbh->selectall_hashref($stmt, 'name');
68     open O, ">", $lic_name_cache or die "open $lic_name_cache failed: $!";
69     print O "# Auto-generated by $0\n# from $lic_name_sqlite\n# All changes will be overwritten\n\n";
70     print O Dumper $lic_name;
71     close O or die "write $lic_name_cache failed: $!";
72   }
73
74 my $lic_name = do $lic_name_cache;
75
76 for my $l (values %$lic_name)
77   {
78     # extend mapping table;
79     $o->add_alias($l->{fullname}, $l->{name});
80   }
81
82 for my $l (values %$lic_name)
83   {
84     # extend mapping table;
85     $o->add_alias($l->{fullname}, $l->{name});
86   }
87
88 for my $k (keys %{$o->{licensemap}{ex}})
89   {
90     ## offer lic_name entries for as many canonical names as possible
91     my $c = $o->{licensemap}{ex}{$k};
92     next if $c eq 'REJECT';
93
94     if ($lic_name->{$k})
95       {
96         # we have a record for this left hand side, 
97         # so clone the record for its right hand side.
98         $lic_name->{$c} = $lic_name->{$k};
99       }
100 #    else
101 #      {
102 #        for my $kk (keys  %{$o->{licensemap}{ex}})
103 #          {
104 #           if ($o->{licensemap}{ex}{$kk} eq $c)
105 #             {
106 #               if ($lic_name->{$kk})
107 #                 {
108 #                   print "<pre>YES $c,$k,$kk,$lic_name->{$kk}</pre>\n" if $c eq 'GPLv2';
109 #                 }
110 #             }
111 #         }
112 #      }
113   }
114 # GPLv2 is still not a key in $lic_name
115
116
117 print qq{
118 <head>
119 <script type="text/javascript" src="overlib/overlib.js"><!-- overLIB (c) Erik Bosrup --></script>
120 <script type="text/javascript">
121 function wizard_add(text)
122 {
123   var e=document.getElementsByName('q');
124   e[0].value += ' ' + text;
125   return nd();
126 }
127
128 function wizard_add_popup(name)
129 {
130   var t;
131   var e=document.getElementsByName('q');
132   if (e[0].value == '')
133     t = 'add: <a href="javascript:void(0);" onclick="return wizard_add('+"'"+name+"'"+');"><font size=+2>'+name+'</font></a><br>';
134   else
135     t = 'as aggregate: <a href="javascript:void(0);" onclick="return wizard_add('+"'; "+name+"'"+');"><font size=+2>;</font> '+name+'</a><br>'+
136         'as choice:    <a href="javascript:void(0);" onclick="return wizard_add('+"'| "+name+"'"+');"><font size=+2>|</font> '+name+'</a><br>'+
137         'as mix:       <a href="javascript:void(0);" onclick="return wizard_add('+"'& "+name+"'"+');"><font size=+2>&</font> '+name+'</a>'
138   return overlib(t, STICKY, MOUSEOFF)
139 }
140
141 /* This script and many more are available free online at
142 The JavaScript Source :: http://javascript.internet.com
143 Created by: Ultimater, Mr J :: http://www.webdeveloper.com/forum/showthread.php?t=77389 */
144
145 function toggleId(a){
146   var e=document.getElementById(a);
147   var t=document.getElementById(a + '_t');
148   if(!e)return true;
149   if(e.style.display=="none"){
150     e.style.display="block"
151     if (t) { t.textContent = "[-]" }
152   } else {
153     e.style.display="none"
154     if (t) { t.textContent = "[+]" }
155   }
156   return true;
157 }
158 </script>
159 </head>
160 <body>
161 <div id="overDiv" style="position:absolute; visibility:hidden; z-index:1000;"></div>
162 <form action=} . self_url($q, {w => $wizard}) . qq{><input type="hidden" name="w" value="$wizard">\n};
163
164 # print "<pre>" . Dumper ($lic_name) . "</pre>";
165
166 my $in_html = qq{<input type="text" size="80" name="q" value="} . CGI::escapeHTML($lic_input) . qq{">\n};
167
168 my $html = qq{};
169
170 if (length $lic_input)
171   {
172     my $canon = $o->canonical_name($lic_input);
173     my $canon_html = qq{
174  <tr><td><br>Canonical license string output:</td></tr>
175  <tr bgcolor="#FFFFFF"><td><font size="+2"><pre> } . CGI::escapeHTML($canon) . qq{</pre></font></td></tr>\n};
176     my $diag_html = '';
177     if ($o->{diagnostics})
178       {
179         $diag_html = qq{<tr><td><br>Diagnostic:</td></tr>
180  <tr bgcolor="#FFFFFF"><td bgcolor="#FF0000"><ul>}.join("\n", map { '<li>'.CGI::escapeHTML($_).'</li>' } @{$o->{diagnostics}}).qq{</td></tr>
181  <tr bgcolor="#FFFFFF"><td>&nbsp;</td></tr>\n};
182       }
183     my $tree = $o->tokenize($canon, 1);
184     my $tree_html = '';
185
186     if (1)      # scalar(@$tree) > 1)
187       {
188         local $Data::Dumper::Terse = 1;
189         local $Data::Dumper::Indent = 1;
190
191         my $lnr=0;
192         # $tree is e.g. [ [ 'X11 MIT','&','GPLv2' ] ,';', [ 'BSD3c','|','IBM PL 1.0'] ]
193         # Here we convert from Data::Dumper format to a very similar HTML.
194         for my $line (split "\n", Dumper $tree)
195           {
196             next if $line =~ m{^[\[\]]$};       # skip opening and closing [] of the array.
197             $lnr++;
198             my $pre = $1 if $line =~ s{^(\s+)}{};       # find the indent
199             $tree_html .= "&nbsp;" x (2*length($pre));  
200             $line =~ s{,$}{};                           # delete comma at the end.
201             $line = $1 if $line =~ m{^'(.*)'$};         # delete quotes
202             $line = '(' if $line eq '[';                # use parens rather than brackes.
203             $line = ')' if $line eq ']';
204             if ($line =~ m{^(\(|\)|\&|\||\;|<<)$})      # explain parenthesis and operators
205               {
206                 my $explain = 
207                 {
208                   '(' => 'Parenthesis are used for grouping. This overrides normal operator precedence.',
209                   '&' => 'License mix. The licenses above and below apply simultaneously. Their clauses mix, and may even conflict. High operator precedence.',
210                   '|' => 'License choice. The licenses above and below are alternatives. The user can pick one and ignore the rest. No conflicts. Medium operator precedence.',
211                   ';' => 'License aggregation. Enumeration of License of independant components. No conflicts. Low operator precedence.',
212                   '<<' => 'License modification. Shift a new clause into a license above. EX(...) adds a permissive exception clause. Highest operator precedence.'
213                 };
214                 $explain->{')'} = $explain->{'('};
215                 
216                 my $e = $explain->{$line} || 'Oops, no help text available';
217                 $tree_html .= qq{<a style="TEXT-DECORATION: NONE" href="toggle: explain $line: $e" onclick="toggleId('p_$lnr'); return false;"><b>$line&nbsp;&nbsp;</b></a>};
218                 $tree_html .= qq{<div id='p_$lnr' style="display:none"><font size="-4">$e</font></div>};
219               }
220             elsif (defined (my $attr = ($lic_name->{$line} || $lic_name->{lc $line})))
221               {
222                 for my $url qw(url url_ext url_1 url_2)
223                   {
224                     $attr->{$url} =~ s{^http://legaldb.suse.de}{http://license.opensuse.org};
225                     $attr->{$url} =~ s{^(.*)$}{<a href="$1">$1</a>};    # make links clickable
226                     delete $attr->{$url} if $attr->{$url} =~ m{/table\.cgi/License\?open=};     # internal one.
227                   }
228                 $tree_html .= qq{<a href="toggle: explain $line" onclick="toggleId('p_$lnr'); return false;">$line</a>};
229                 $tree_html .= qq{<div id='p_$lnr' style="display:none"><font size="-1"><pre>}.Dumper($attr).qq{</pre></font></div>};
230
231                 
232               }
233
234             elsif ($line =~ m{^\?(.*)\?$})
235               {
236                 my $what = $1;
237                 my %candidates;
238                 for my $ll (values %{$o->{licensemap}{lc}})
239                   {
240                     my $l = lc $ll; 
241                     next if $l =~ m{^(dual|any)\b};
242                     $candidates{$ll}++ if $l =~ m{\b\E$what\Q}i;
243                   }
244                 my $candidates = join ', ', sort {lc $a cmp lc $b} keys %candidates;
245                 
246                 $tree_html .= qq{<a href="toggle: explain $line" onclick="toggleId('p_$lnr'); return false;">$line</a>};
247                 $tree_html .= qq{<div id='p_$lnr' style="display:none"><font size="-4">
248                 Unknown license name '$what'. };
249                 if (length $candidates)
250                   {
251                     if (scalar @candidates == 1)
252                       {
253                         $tree_html .= qq{Did you mean this: ?<br>$candidates</font></div>};
254                       }
255                     else
256                       {
257                         $tree_html .= qq{Did you mean one of these: ?<br>$candidates</font></div>};
258                       }
259                   }
260                 else
261                   {
262                         $tree_html .= qq{Not even a substring match.</font></div>};
263                   }
264               }
265             else
266               {
267                 $tree_html .= $line;
268               }
269             $tree_html .= "<br>\n";
270           }
271         $tree_html = qq{<tr><td bgcolor="#FFFFFF">$tree_html<br></td></tr>\n};
272       }
273     $html = qq{<table bgcolor="#77ee77">\n} . $diag_html . $tree_html . $canon_html . qq{</table>\n};
274   }
275
276 if ($wizard)
277 {
278   my $w_html = wizard_html($q);
279   my $url = self_url($q, { q => $lic_input, w => 0 });
280   print qq{
281 <table border=0 width=100%>
282  <tr>
283   <td align=left>License string input:</td>
284   <td align=right>&nbsp;</td>
285  </tr>
286  <tr>
287   <td colspan=2>$in_html</td>
288  </tr>
289  <tr>
290   <td><input type=submit value="Analyze"><p><br></td>
291   <td align=right><font size="-4"><a href="$url">close license wizard</a></font></td>
292  </tr>
293  <tr>
294   <td width=50% valign="top">$html</td>
295   <td width=50% valign="top">$w_html</td>
296  </tr>
297 </table>\n};
298 }
299 else
300 {
301   my $url = self_url($q, { q => $lic_input, w => 1 });
302   print qq{
303 <table border=0 width=100%>
304  <tr>
305   <td align=left>License string input:</td>
306   <td align=right>&nbsp;</td>
307  </tr>
308  <tr>
309   <td colspan=2>$in_html</td>
310  </tr>
311  <tr>
312   <td><input type=submit value="Analyze"></td>
313   <td align=right><font size="-2"><a href="$url">open license wizard</a></td>
314  </tr>
315  <tr>
316   <td colspan=2 valign="top">$html</td>
317  </tr>
318 </table>\n};
319 }
320
321 print qq{<table width=100%><tr><td align=right><small>jw\@suse.de</small></td></tr></table>\n};
322
323 print "</form><pre>" . ("\n" x 10) .
324 foldable_html('data dump', 0,  Dumper {table => $lic_name, obj => $o, cgi_env => \%ENV});
325 print "</body>\n";
326
327 exit 0;
328
329 ############################################
330
331 sub wizard_html
332 {
333   my ($q) = @_;
334   my %list;
335   for my $k (keys %{$o->{licensemap}{ex}})
336     {
337       my $c = $o->{licensemap}{ex}{$k};
338       $list{$c}{alias}{$k}++;
339       $list{$c}{attr} ||= $lic_name->{$c} || $lic_name->{$k};
340       $list{$c}{alias}{$list{$c}{attr}{fullname}}++;
341     }
342   my $html = qq{};
343   my @letters = qw(abc def ghi jkl mno pqr stu vwx yz.);
344
345   my $sel_html = '';
346   for my $letter (@letters)
347     {
348       my $first = substr $letter, 0, 1;
349       my $url = self_url($q, { w => $first });
350       if ($letter =~ m{$wizard})
351         {
352           $sel_html .= " $letter";
353         }
354       else
355         {
356           $sel_html .= qq{ <a href="$url">$letter</a>};
357         }
358     }
359   
360   $html .= qq{<center><font size="-3">$sel_html</font></center>};
361   $html .= qq{<table bgcolor="#77ee77"><tr><th>name</th><th>alias</th><th>id</th></tr>\n};
362   for my $k (sort {lc $a cmp lc $b} keys %list)
363     {
364       my $match = substr $letters[-1],0,1;
365       for my $l (@letters)
366         {
367           my $lcfirst = lc substr $k,0,1;
368           $match = substr($l,0,1) if $l =~ m{\Q$lcfirst\E};
369         }
370       next if $wizard ne '1' and $wizard ne $match;
371
372       next if $k =~ m{^\(.*;};
373       next if $k =~ m{^any\b}i;
374       delete $list{$k}{alias}{$k};
375       my $alias = join '<br>', map { CGI::escapeHTML($_) } sort {$a cmp $b} keys %{$list{$k}{alias}};
376       my $id = $list{$k}{attr}{id} || '';
377       $html .= qq{ <tr bgcolor="#FFFFFF">
378   <td><font size="-2">}.wizard_add_popup($k).qq{</td>
379   <td><font size="-3">$alias</td>
380   <td align=right><font size="-2">$id</td>
381  </tr>\n};
382     }
383   $html .= qq{</table>\n};
384   return $html;
385 }
386
387 sub wizard_add_popup
388 {
389   my ($name) = @_;
390   return qq{<a href="add: $name" onclick="return wizard_add_popup('$name');" onmouseout="return nd();">}.CGI::escapeHTML($name).'</a>';
391 }
392
393 ##
394 ## returns the merge of two hashes. the second one takes precedence.
395 ## if the second one contains undef values, those keys will not appear in the merge.
396 ##
397 sub merge_hash
398 {
399   my ($h1, $h2) = @_;
400
401   my %h = ();
402   %h = %$h1 if $h1;
403   for my $k (keys %$h2)
404     {
405       $h{$k} = $h2->{$k};
406       delete $h{$k} unless defined $h2->{$k};
407     }
408   return \%h;
409 }
410
411 sub self_url
412 {
413   my ($cgi, $q) = @_;
414   my $h = merge_hash($cgi->{p}, $q);
415   delete $h->{'/'};
416   my $path = $q->{'/'};
417   unless (defined $path)
418     {
419         ## relative must not be combined with other params. Seems to imply them.
420         #      $path = $cgi->self_url(-path_info=>0, -query=>0, -relative=>1);
421       $path = $cgi->url(-relative=>1);
422     }
423   elsif ($path ne '' and $path !~ m{^(/|\w+://)})
424     {
425       #prefix script name
426       $path = $cgi->self_url(-path_info=>0, -query=>0) . "/" . $path;
427     }
428
429   my $s = '';
430   for my $p (sort keys %$h)
431     {
432       my $v = $h->{$p};
433       $v = [ $v ] unless ref $v;
434       for my $i (@$v)
435         {
436           $i = '' unless defined $i;
437           $s .= "&$p=" . CGI::Util::escape($i);
438         }
439     }
440
441   substr($s, 0, 1) = '?' unless $path =~ m{\?};
442   return $path . $s;
443 }
444
445 sub foldable_html
446 {
447   my ($id, $show, $text) = @_;
448   my $trigger = $show ? '[-]' : '[+]';
449   # $trigger = '[+/-]';
450
451   $show = $show ? 'block' : 'none';
452
453   my $trigger = qq{<a id='${id}_t' href="toggle: $id" onclick="toggleId('$id'); return false;">$trigger</a>};
454   my $div     = qq{<span id='$id' style="display:$show">$text</span>};
455
456   return ($trigger, $div) if wantarray;
457   return $trigger . ' ' . $div;
458 }