automatic agpl compliance: dumps data, does not yet generate

diff --git a/cgi-auth-flexible.pm b/cgi-auth-flexible.pm
index 2be63b4a242926ff1ef9c9a88dcec34dc6c4acf0..81a12aae47667b72774703947d772ee932c8add6 100644 (file)
--- a/cgi-auth-flexible.pm
+++ b/cgi-auth-flexible.pm
@@ -174,19 +174,19 @@ sub gen_plain_login_link ($$) {
            '</a>');
 }
 
-sub gen_special_link_html ($$$$) {
+sub gen_srcdump_link_html ($$$$) {
     my ($c,$r,$anchor,$specval) = @_;
-    my %params = ($r->{S}{special_param_name} => [ $specval ]);
+    my %params = ($r->{S}{srcdump_param_name} => [ $specval ]);
     return '<a href="'.escapeHTML($r->url_with_query_params(\%params)).'">'.
        $anchor."</a>";
 }
 sub gen_plain_licence_link_html ($$) {
     my ($c,$r) = @_;
-    gen_special_link_html($c,$r, 'GNU Affero GPL', 'licence');
+    gen_srcdump_link_html($c,$r, 'GNU Affero GPL', 'licence');
 }
 sub gen_plain_source_link_html ($$) {
     my ($c,$r) = @_;
-    gen_special_link_html($c,$r, 'Source available', 'source');
+    gen_srcdump_link_html($c,$r, 'Source available', 'source');
 }
 
 sub gen_plain_footer_html ($$) {
@@ -200,26 +200,39 @@ sub gen_plain_footer_html ($$) {
 
 #---------- licence and source code ----------
 
-sub dump_licence ($$$) {
-    
-    my ($c,$r, $fh) = @_;
-    foreach my $incdir ($r->_ch('getsource_includedirs')) {
-       
-    }
-}
+#sub dump_licence ($$$) {
+#    
+#    my ($c,$r, $fh) = @_;
+#    foreach my $incdir ($r->_ch('getsource_includedirs')) {
+#      
+#    }
+#}
 
-sub source_dump_get_path ($$$) {
-    my ($c,$r, $thing) = @_;
-    die if $thing =~ m/\W/;
-    my $pat = $r->{S}('source_dump_path_pat');
-    my $leaf = sprintf $pat, $thing;
-    return $r->_absify_path($leaf);
+sub srcdump_dump_thing ($$$) {
+    my ($c,$r, $thing, $outfn) = @_;
+    die if $thing =~ m/\W/ || $thing !~ m/\w/;
+    my $path = $r->_get_path('srcdump');
+    my $ctf = new IO::File "$path/$thing.ctype", 'r'
+       or die "$path/$thing.ctype $!";
+    my $ct = <$ctf>;
+    chomp $ct or die "$path/$thing ?";
+    $ct->close or die "$path/$thing $!";
+    my $df = new IO::File "$path/$thing.data", 'r'
+       or die "$path/$thing.data $!";
+    $r->_ch('dump', $ct, $df);
 }
 
-sub source_dump_thing ($$$) {
-    my ($c,$r, $thing, $outfn) = @_;
-    my $path = $r->_ch('source_dump_get_path', $thing);
-    copy($path, $utfn
+sub dump_plain ($$$$) {
+    my ($c, $r, $ct, $df) = @_;
+    $r->_print($c->header(-type $ct));
+    my $buffer;
+    for (;;) {
+       my $got = read $df, $buffer, 65536;
+       die $! unless defined $got;
+       return if !$got;
+       $r->_print($buffer);
+    }
+}
 
 #---------- verifier object methods ----------
 
@@ -231,8 +244,7 @@ sub new_verifier {
            assocdb_dbh => undef, # must have AutoCommit=0, RaiseError=1
            assocdb_path => 'caf-assocs.db',
            keys_path => 'caf-keys',
-           source_dump_path_pat => 'caf-%s.dump',
-           source_dump_get_path => \&source_dump_get_path,
+           srcdump_path => 'caf-srcdump',
            assocdb_dsn => undef,
            assocdb_user => '',
            assocdb_password => '',
@@ -247,7 +259,7 @@ sub new_verifier {
            dummy_param_name_prefix => 'caf__',
            cookie_name => "caf_assocsecret",
            password_param_name => 'password',
-           special_param_name => 'caf_special',
+           srcdump_param_name => 'caf_srcdump',
            username_param_names => [qw(username)],
            form_entry_size => 60,
            logout_param_names => [qw(caf_logout)],
@@ -279,7 +291,7 @@ sub new_verifier {
            gen_login_form => \&gen_plain_login_form,
            gen_login_link => \&gen_plain_login_link,
            gen_postmainpage_form => \&gen_postmainpage_form,
-           source_dump_thing => \&source_dump_thing,
+           srcdump_dump_thing => \&srcdump_dump_thing,
            source_includedirs => sub { grep { !m#^/etc/# } @INC; },
            gettext => sub { gettext($_[2]); },
            print => sub { print $_[2] or die $!; },
@@ -421,8 +433,8 @@ sub _debug ($@) {
 }
 
 sub _get_path ($$) {
-    my ($v,$keybase) = @_;
-    my $leaf = $v->{S}{"${keybase}_path"};
+    my ($r,$keybase) = @_;
+    my $leaf = $r->{S}{"${keybase}_path"};
     return $r->_absify_path($leaf);
 }
 
@@ -565,10 +577,10 @@ my @ca = (-name => $r->{S}{cookie_name},
 sub _check_divert_core ($) {
     my ($r) = @_;
 
-    my $special = $r->_rp('special_param_name');
-    if ($special) {
-       die if $special =~ m/\W/;
-       return ({ Kind => 'SPECIAL-'.uc $special,
+    my $srcdump = $r->_rp('srcdump_param_name');
+    if ($srcdump) {
+       die if $srcdump =~ m/\W/;
+       return ({ Kind => 'SRCDUMP-'.uc $srcdump,
                  Message => undef,
                  CookieSecret => undef,
                  Params => { } });
@@ -853,8 +865,8 @@ sub check_ok ($) {
     my $params = $divert->{Params};
     my $cookie = $r->construct_cookie($cookiesecret);
 
-    if ($kind =~ m/^SPECIAL-(LICENCE|SOURCE)$/) {
-       $r->_ch('dump_'.lc $1, \*STDOUT);
+    if ($kind =~ m/^SRCDUMP-(\w+)$/) {
+       $r->_ch('srcdump_dump_thing', (lc $1));
        return 0;
     }