Apache-NNTPGateway
1 match

 view release on metacpan or  search on metacpan

NNTPGateway.pm  view on Meta::CPAN 

      if ( $Article ) {
        &print_html_article( $r, $Article, 1, &is_true( $Args->{long} ));
      } else {
        $r->print( "<span id=\"bad_id\"><strong>", &message('no_id', $i ), "</strong></span><br>\n" );
      }
    }
    # Print the list menu
    $r->print( "\n<hr noshade>\n" );
    &print_html_list_menu( $r, $n_arts );

  } else {

    # No articles to display...
    &print_html_list_menu( $r, $n_arts );

  }

  # Print global menu
  &print_html_menu( $r );
  # Print html footer
  &print_html_foot( $r );
  return;

} # end action_list();


### Sub action_catchup() ###
# &action_catchup( request ):
# - Description: Mark all articles in the group as read.
# - Arguments  : the Apache request
###
sub action_catchup ( $ ) {
  my ($r) = @_;
  
  # Prepare catchup...
  my $catchupid   = $Args->{last_art};
  my $catchupdate = $NNTP->date();
  my $newnewsok   = $NNTP->newnews( $catchupdate, $The_Newsgroup )?1:0;

  # Build the catchup cookie
  my $cookie      = new CGI::Cookie 
    ( 
     -name    => $Catchup_Cookie_Name, 
     -value   => "Id=${catchupid},Date=${catchupdate}", 
     # 10 years should be enough as expiration date.
     -expires => '+10y', 
     -domain  => $COOKIE_DOMAIN, 
     -path    => $Base
    );
  $r->header_out( 'Set-Cookie' => $cookie );

  # Print html header
  &print_html_head( $r, 1 );
  # Print menu
  &print_html_menu( $r );
  $r->print( "\n<hr noshade>\n" );

  # Just Inform user
  $r->print
    ( 
     "<h2 align=\"center\">${NewsUrl}<br>\n<font color=\"red\">", 
     &message( 'catchup_at', scalar( localtime( $catchupdate ))), 
     "</font></h2>\n", 
     "<div align=\"center\">[<a href=\"${Base}/list?force=1\">", 
     &message( 'list_all' ), 
     "</a>]</div>\n" 
    );

  # Print menu
  $r->print( "\n<hr noshade>\n" );
  &print_html_menu( $r );
  # Print html footer
  &print_html_foot( $r );
  return;

} # end action_catchup();


### Sub action_last() ###
# &action_last( request [, force] ):
# - Description: Print last article in the group.
# - Arguments  : the Apache request
###
sub action_last ( $\$ ) {
  my ($r, $force) = @_;
  my $id_last = $Args->{last_art};
  # Everything is handled by action_read with ID of last article. And
  # as last article could always change caching is not allowed.
  &action_read( $r, $id_last, 1 );
  return;

} # end action_last();


### Sub action_read() ###
# &action_read( request [, id, no-cache] ):
# - Description: Print article given it's Id.
# - Arguments  : the Apache request, article id to read
###
sub action_read ( $\$$ ) {
  my ($r, $id, $no_cache ) = @_;

  # Get id of article to read
  my $args = $Args->{action_args};
  if ( $args && @$args ) {
    # id of article to read
    $id ||= $args->[0];
  } else {
    $id ||= $Args->{last_art};
  }

  # Get the article and print it.
  my $Article = &nntp_get_article( $id );
  if ( $Article ) {

    # Got it!
    my $title = $Article->{Header}{subject} || "article $id";
    &print_html_head( $r, $no_cache, $title );
    &print_html_menu( $r );
    &print_html_article( $r, $Article, 0, 
                         $Args->{headers} eq 'max', 
                         $Args->{showsig} );
  } else {

NNTPGateway.pm  view on Meta::CPAN 

         "\t<caption><strong>", &message( 'posted', $NewsUrl ), "</strong></caption>\n", 
         "\t<tr>\n", 
         "\t\t<td width=\"5%\"><strong><u>", &message('from'), "</u>:</strong></td>\n", 
         "\t\t<td bgcolor=\"$HEADER_BGCOLOR1\"><span class=\"$article_from_class\">$from</span></td>\n", 
         "\t</tr>\n", 
         "\t<tr>\n", 
         "\t\t<td width=\"5%\"><strong><u>", &message('subject'), "</u>:</strong></td>\n", 
         "\t\t<td bgcolor=\"$HEADER_BGCOLOR1\"><span class=\"$article_subject_class\">$subject</span></td>\n", 
         "\t</tr>\n", 
         "\t<tr>\n", 
         "\t\t<td colspan=\"2\" bgcolor=\"$BODY_BGCOLOR\"><pre>$body</pre></td>\n", 
         "\t</tr>\n", 
         "</table>\n", 
        );
    } else {
      # Post failed
      &print_html_error( $r, &message( 'no_post_ok' ));
    }
    
  } else {

    # In a GET method: Print the form to post the article
    &print_html_post_form( $r );
    # The real nntp post is handled here when the method, invoked from
    # a submit in the post form, is a POST.

  }

  # Print menu
  $r->print( "\n<hr noshade>\n" );
  &print_html_menu( $r );
  # Print html footer
  &print_html_foot( $r );
  return;

} # end action_post();




# HTML Utilities ----------------------------------------------------


### Sub print_html_article() ###
# &print_html_article( args ):
# - Description:
# - Arguments  :
###
sub print_html_article ( $$\$$$ ) {
  my ($r, $A, $header_only, $fullheaders, $showsig) = @_;
  my $id = $A->{Id};
  $r->print( "\n<!-- article $id -->\n" );
  if ( $header_only && $fullheaders ) {

    # Print one line only article but with some more headers
    $r->print
      (
       "<table width=\"100%\">\n", 
       "\t<tr>\n", 
       "\t<td bgcolor=\"$HEADER_BGCOLOR2\" width=\"15%\">\n", 
       "\t\t<font size=\"-1\"><a name=\"__${id}__\">${id}</a>:&nbsp;", 
       "[<a href=\"${Base}/read/${id}\">", &message('read'), "</a>]", 
       "[<a href=\"${Base}/followup/${id}\">", &message('followup'), "</a>]", 
       "</font></td>\n", 
       "\t<td bgcolor=\"$HEADER_BGCOLOR1\" align=\"center\" width=\"30%\">\n", 
       "\t\t",
       "<span class=\"$article_date_class\"><font size=\"-1\"><em>", $A->{Header}{date}, "</em></font></span>", 
       "</td>\n", 
       "\t<td bgcolor=\"$HEADER_BGCOLOR1\" align=\"center\">\n", 
       "\t\t<font size=\"-1\"><em><a href=\"mailto:", $A->{Header}{_from_email}, "\">", 
       "<span class=\"$article_from_class\"><strong>", $A->{Header}{_from_name}, "</strong></span>", 
       "</a></em></font></td>\n", 
       "\t</tr>\n", 
       "\t<tr>\n", 
       "\t<td align=\"right\" width=\"15%\"><font size=\"-1\"><em>", 
       $A->{Header}{lines}, " lines</em></font>&nbsp;</td>\n", 
       "\t<td colspan=\"2\" bgcolor=\"$BODY_BGCOLOR\">&nbsp;&quot;<a href=\"${Base}/read/${id}\">", 
       "<span class=\"$article_subject_class\">", $A->{Header}{_subject_html}, "</span>", 
       "</a>&quot;</td>\n", 
       "\t</tr></table>\n", 
      );

  } elsif ( $header_only ) {

    # Print one line only article
    $r->print
      (
       "<div class=\"$article_class\">",
       "<span class=\"$article_id_class\"><strong><a name=\"__${id}__\">$id</a></strong></span>", 
       ":&nbsp;&quot;<a href=\"${Base}/read/${id}\">", 
       "<span class=\"$article_subject_class\"><em>", $A->{Header}{_subject_html}, "</em></span>", 
       "</a>&quot;&nbsp;", lc(&message('from')), "&nbsp;",
       "&lt;<a href=\"mailto:", $A->{Header}{_from_email}, "\">", 
       "<span class=\"$article_from_class\"><font size=\"-1\">", $A->{Header}{_from_name}, "</font></span>", 
       "</a>&gt;<br>",
       "</div>\n", 
      );

  } else {

    # Print the full article
    $r->print( "<table width=\"100%\"><a name=\"__${id}__\">&nbsp;</a>\n", );
    &print_html_article_menu( $r, $A, 1 );
    $r->print
      (
       "\t<tr>\n",
       "\t<td><strong><u>", &message('from'), "<u>:</strong></td>\n", 
       "\t<td bgcolor=\"$HEADER_BGCOLOR1\"><a href=\"mailto:", 
       $A->{Header}{_from_email}, "?Subject=Re:%20", $A->{Header}{_subject_html}, "\">", 
       "<span class=\"$article_from_class\">", $A->{Header}{_from_name}, "</span>", 
       "</a></td>\n",
       "\t</tr>\n", 
       "\t<tr>\n",
       "\t<td><strong><u>", &message('date'), "<u>:</strong></td>\n", 
       "\t<td bgcolor=\"$HEADER_BGCOLOR1\">", 
       "<span class=\"$article_date_class\">", $A->{Header}{date}, "</span>", 
       "</td>\n", 
       "\t</tr>\n", 
       "\t<tr>\n",
       "\t<td><strong><u>", &message('subject'), "<u>:</strong></td>\n", 
       "\t<td bgcolor=\"$HEADER_BGCOLOR1\">", 
       "<span class=\"$article_subject_class\"><strong>", $A->{Header}{_subject_html}, "</strong></span>", 
       "</td>\n", 
       "\t</tr>\n", 
      );

    if ( $fullheaders ) {

      # Print all headers
      foreach ( keys( %{$A->{Header}} )) {
        # Do not print already printed headers and private internals _headers.
        next if exists $Used_Headers_Map{$_} || $_ =~ /^_/; 
        $r->print
          (
           "\t<tr>\n", 
           "\t<td><em><u>$_</u>:</em></td>\n", 
           "\t<td bgcolor=\"$HEADER_BGCOLOR2\">", $A->{Header}{$_}, "</td>\n", 
           "\t</tr>\n", 
          );
      }
      $r->print
        (
         "\t<tr>\n",
         "\t<td colspan=\"2\"><font size=\"-1\">", 
         "[<a href=\"${Base}/read/${id}?headers=min\">", &message('nofullheaders'), "</a>]", 
         "</font></td>\n",
         "\t</tr>\n", 
        );
    } else {
      $r->print
        (
         "\t<tr>\n",
         "\t<td colspan=\"2\"><font size=\"-1\">", 
         "[<a href=\"${Base}/read/${id}?headers=max\">", &message('fullheaders'), "</a>]", 
         "</font></td>\n", 
         "\t</tr>\n", 
        );
    }
    # The body here ...
    $r->print
      (
       "\t<tr>\n", 
       "\t<td colspan=\"2\"><hr><pre><font size=\"+1\">", $A->{Body}, "</font></pre>\n", 
      );
    # The .sig ...
    if ( $A->{Signature} ) {
      if ( $showsig ) {
        $r->print( "<a href=\"${Base}/read/${id}?showsig=0\">--</a>\n" );
        $r->print( "<pre><font size=\"-1\" color=\"white\"><i>", $A->{Signature}, "</i></font></pre>\n" );
      } else {
        $r->print( "<a href=\"${Base}/read/${id}?showsig=1\"><b>--</b></a>\n" );
      }
    }

    $r->print( "<hr></td>\n\t</tr>\n" );
    &print_html_article_menu( $r, $A, 1 );
    $r->print( "</table>\n" );

  }
  $r->print( "\n<!-- /article $id -->\n" );
  return;

} # end print_html_article();



### Sub print_html_article_menu() ###
# &print_html_article_menu( request, Article, in_table ):
# - Description:
# - Arguments :
# - Return    :
###
sub print_html_article_menu ( $$\$ ) {
  my ($r, $A, $table) = @_;
  my $id = $A->{Id};
  $r->print
    (
     "\t<tr>\n", 
     "\t<td><u>Article Id</u>:&nbsp;<strong>$id</strong>:</td>\n", 
     "\t<td bgcolor=\"$MENU_BGCOLOR\">\n", 
    ) if $table;
  $r->print( "\t\t<font color=\"blue\" size=\"-1\">\n" );
  unless ( $Disabled_Actions{'read'} ) {
    if ( $A->{Header}{_prev} ) {
      $r->print( "\t\t&lt;<a href=\"${Base}/read/", $A->{Header}{_prev}, "\">", 
                 &message('prev'), "</a>&lt;\n" );
    } else {
      $r->print( "\t\t&lt;<em>", &message('prev'), "</em>&lt;\n" );
    }
  }
  $r->print( 
            "\t\t[<a href=\"${Base}/followup/${id}\">",     
            &message('followup'), "</a>]\n",
            ) unless $Disabled_Actions{'followup'};
  $r->print( 
            "\t\t[<a href=\"${Base}/list?force=1#__${id}__\">",     
            &message('list'),     "</a>]\n", 
            ) unless $Disabled_Actions{'list'};
  unless ( $Disabled_Actions{'read'} ) {
    if ( $A->{Header}{_next} ) {
      $r->print( "\t\t&gt;<a href=\"${Base}/read/", $A->{Header}{_next}, "\">", 
                 &message('next'),  "</a>&gt;\n" );
    } else {
      $r->print( "\t\t&gt;<em>", &message('next'), "</em>&gt;\n" );
    }
  }
  $r->print( "\t</font>\n" );
  $r->print
    (
     "\t</td>\n", 
     "\t</tr>\n", 
    ) if $table;
  return;

} # end print_html_article_menu();



### Sub print_html_list_menu() ###
# &print_html_list_menu( request ):
# - Description:
# - Arguments :
# - Return    :
###
sub print_html_list_menu ( $$ ) {
  my ($r, $n_arts) = @_;
  my $long      = &is_true( $Args->{long} );
  my $force     = &is_true( $Args->{force} );
  my $long_arg  = $long?"long=1":"long=0";
  my $force_arg = $force?"force=1":"force=0";

  $r->print( "\n<table width=\"100%\" align=\"center\"><tr><td width=\"20%\">" );
  if ( $force && $n_arts > 0 ) {
    $r->print( "<strong>$n_arts&nbsp;articles<strong>" );
  } elsif ( $n_arts > 0 ) {
    $r->print( "<strong>", &message( 'n_unread', $n_arts ), "</strong>" );
  } else {
    $r->print( "<font color=\"red\">", &message( 'no_unread' ), "</font>" );
  }

  $r->print( "</td><td align=\"center\" bgcolor=\"$MENU_BGCOLOR\">&nbsp;" );
  if ( $n_arts > 0 ) {
    if ( $long ) {
      $r->print( "[<a href=\"${Base}/list?long=0&${force_arg}\">", &message( 'short_format' ), "</a>]&nbsp;\n" );
    } else {
      $r->print( "[<a href=\"${Base}/list?long=1&${force_arg}\">", &message( 'long_format' ),  "</a>]&nbsp;\n" );
    }
  }
  if ( $force & $n_arts <= 0 ) {
    $r->print( "<font color=\"red\">", &message( 'no_arts' ), "<font>" );
  } elsif ( $force ) {
    $r->print( "[<a href=\"${Base}/list?force=0&${long_arg}\">", &message( 'list_new' ),     "</a>]&nbsp;\n" );
  } else {
    $r->print( "[<a href=\"${Base}/list?force=1&${long_arg}\">", &message( 'list_all' ),     "</a>]&nbsp;\n" );
  }
  if ( $n_arts > 0 ) {
    $r->print( "[<a href=\"${Base}/catchup\">Catchup</a>]&nbsp;\n" ) unless $Disabled_Actions{catchup};
  }
  $r->print( "</td>\n</tr></table>\n" );

  return;

} # end print_html_list_menu();



### Sub print_html_post_form() ###
# $ret = &print_html_post_form( args ):
# - Description:
# - Arguments :
# - Return    :
###
sub print_html_post_form ( $\$$$ ) {
  my ($r, $subject, $body, $refs) = @_;
  $r->print( 
            "<table width=\"100%\">\n", 
            "\t<form method=\"POST\" action=\"${Base}/post\">\n", 
            "\t<tr>\n", 
            "\t<td>&nbsp;</td>\n", 
            "\t<td><font size=\"-1\" color=\"red\"><strong>", &message('all_fields'), "</strong></font></td>\n", 
            "\t</tr>\n", 
            );
  $r->print( "<input type=\"hidden\" name=\"refs\" value=\"$refs\">" ) if $refs;
  # Build a choice of From
  $r->print( 
            "\t<tr>\n", 
            "\t<td width=\"5%\"><strong><u>", &message('from'), "</u>:</strong></td>\n", 
            "\t<td bgcolor=\"$HEADER_BGCOLOR2\"><select name=\"from\">", 
            );
  foreach (keys %From_Posters) {
    $r->print( "<option value=\"$_\">", $From_Posters{$_} );
  }
  $r->print( 
            "</select></td>\n", 
            "\t</tr>\n", 
            );

  # Subject & Body fields
  $r->print( 
            "\t<tr>\n", 
            "\t<td width=\"5%\"><strong><u>", &message('subject'), "</u>:</strong></td>\n", 
            "\t<td bgcolor=\"$HEADER_BGCOLOR2\">\n", 
            "\t\t<input type=\"textfield\" name=\"subject\" value=\"$subject\" size=\"60\" maxlength=\"80\">\n", 
            "\t</td>\n", 
            "\t</tr>\n", 
            "\t<tr>\n", 
            "\t<td>&nbsp;</td>\n", 
            "\t<td bgcolor=\"$BODY_BGCOLOR\">\n", 
            "\t\t<textarea name=\"body\" wrap=\"hard\" rows=\"20\" cols=\"60\">$body</textarea>\n", 
            "\t</td>\n", 
            "\t</tr>\n", 
            "\t<tr>\n", 
            "\t<td colspan=\"2\" align=\"center\"><input type=\"submit\" value=\"", 
            &message('post'), "\"><input type=\"reset\" value=\"", &message('reset'), "\"></td>\n", 
            "\t</tr>\n", 
            "\t</form></table>\n", 
            );
  return;

} # end print_html_post_form();



### Sub print_html_head() ###
# &print_html_head( request ):
# - Description:
# - Arguments :
# - Return    :
###
sub print_html_head ( $\@ ) {
  my ( $r, $no_cache, $extra_title ) = @_;
  my $title = $Title;
  $title .= ": $extra_title" if $extra_title;
  $r->content_type( 'text/html' );
  # Goood, but some more efforts are needed ...
  $r->no_cache($no_cache?1:0);
  $r->send_http_header();
  $r->print( 
            "\n\n${HTML_DTD}\n", 
            "<html>\n", 
            "<head>\n", 
            "<title>${title}</title>\n", 
             $StyleSheet?"<LINK REL=StyleSheet HREF=\"$StyleSheet\" TYPE=\"text/css\">":"<!-- no StyleSheet -->", 
             "</head>\n", 
            "<body bgcolor=\"$BODY_BGCOLOR\">\n", 
            "<a name=\"TOP\">&nbsp;</a>\n", 
            "<hr noshade>\n", 
            "<div align=\"right\" class=\"head\"><font size=\"-1\">\n", 
            "\t<a href=\"$Base\">$PKG_NAME</a>&nbsp;\@&nbsp;<a href=\"$NewsUrl\">$NewsUrl</a>\n", 
            "</font></div>\n", 
            "<h1 align=\"right\" class=\"title\"><a href=\"$Base\">${title}</a></h1>\n", 
            
           );
  $r->print( "<h3 align=\"right\">($The_GroupDescription)</h3>\n" ) if $The_GroupDescription;

  return;
} # end print_html_head();



### Sub print_html_foot() ###
# &print_html_foot( request ):
# - Description:
# - Arguments : the request
###
sub print_html_foot ( $ ) {
  my ($r) = @_;
  $r->print( 
            "<hr noshade>\n", 
            "<div align=\"right\" class=\"copyright\"><em><a href=\"$PKG_HOMEPAGE\">$PKG_COPYRIGHT</a></em></div>\n", 
            "<hr noshade>\n", 
            "</body></html>\n", 
           );
  return;
} # end print_html_foot();



### Sub print_html_menu() ###
# &print_html_menu( request [, action] ):
# - Description:
# - Arguments : the request, the current action.
###
sub print_html_menu ( $\$ ) {
  my ($r, $action) = @_;
  $action ||= $The_Action;
  $r->print( "\n<table width=\"100%\" align=\"center\"><tr><td bgcolor=\"$MENU_BGCOLOR\" align=\"center\">" );
  foreach ( keys %Actions_Map ) {
    next unless $Menu_Entries_Map{$_};
    next if $Disabled_Actions{$_};
    my $Aname = &message($_);
    $Aname = $_ =~ s/^([a-z]{1,1})/uc( $1 )/e unless $Aname;
    if ( $_ eq $action ) {
      $r->print( "<font color=\"red\">[&nbsp;${Aname}&nbsp;]</font>" );
    } else {
      $r->print( "<font color=\"blue\">[&nbsp;<a href=\"${Base}/$_\">${Aname}</a>&nbsp;]</font>" ); 
    } 
  }
  $r->print( "</td></tr></table>\n" );
  return;

} # end print_html_menu();



### Sub print_html_error() ###
# $ret = &print_html_error( args ):
# - Description:
# - Arguments :
# - Return    :
###
sub print_html_error ( $\$$$ ) {
  my ($r, $h1, $err, $msg) = @_;
  $h1  ||= &message('error');
  $r->print(
            "<h1 align=\"center\">$h1</h1>\n<p>", 
            $err?"<div align=\"center\" class=\"error\"><font color=\"red\"><strong>$err</strong></font></div><p>\n":"", 
           );
  return;
} # end print_html_error();



### Sub to_html() ###
# $ret = &to_html( args ):
# - Description:
# - Arguments :
# - Return    :
###
sub to_html ( $ ) {
  my $v = shift;
  $v =~ s/&/&amp;/g;#this should be the 1st one!!
  $v =~ s/</&lt;/g;
  $v =~ s/>/&gt;/g;
  $v =~ s/\s+/&nbsp;/g;
  $v =~ s/\"/&quot;/g;
  return $v;
} # end to_html();




# NNTP Utilities ----------------------------------------------------


### Sub nntp_connect() ###
# status = &nntp_connect( request ):
# - Description: Try hardly to connect to the nntp server.
# - Arguments  : the Apache request
# - Return     : 1=ok, 0=failure
###
sub nntp_connect ( $ ) {
  my $r = shift;
  my $already_tried = 0;
 NNTPConnect:
  unless ( $NNTP ) {
    $r->log->notice( "($$) Connecting to $NewsUrl ..." ) if $DEBUG;
    $already_tried = 1;
    # Not yet connected or disconnected
    $NNTP = new Net::NNTP( $NNTP_Server, 'Debug' => $DEBUG?1:0 );
    unless ( $NNTP ) {
      &print_nntp_error( $r, "Could not connect to NNTP Server $NNTP_Server."  );
      $NNTP = undef;
      return 0;
    }
  } elsif ( not( $NNTP->connected()) && 
            not( $already_tried )) {
    # Timed out connection
    $r->log->notice( "($$) Reconnecting old NNTP connection ..." ) if $DEBUG;
    # $NNTP->connect( ... ); # Buggy!!!
    $NNTP->quit();
    $NNTP = undef;
    goto NNTPConnect;
  } else {
    $r->log->notice( "($$) Reusing old NNTP connection ..." ) if $DEBUG;
  }
  #my $NNTP_HOST = $NNTP->sockhost();

NNTPGateway.pm  view on Meta::CPAN 

    }
  }
  # Get previous article id:
  if ( exists $Article{Header}{references} ) {
    my @refs = split( '\s', $Article{Header}{references} );
    my ($prev) = $refs[$#refs] =~ /<([^>]+)>/;
    $Article{Header}{'x-followup-of'} = $prev if $prev;
  }   
  if ( $Args->{first_art} <= ($id -1)) {
    $Article{Header}{_prev} = $id -1;
  }
  # Get next article id:
  if ( $Args->{last_art} >= ($id +1)) {
    $Article{Header}{_next} = $id +1;
  }
  # Get all the article if needed
  unless ( $header_only ) {
    my $body = $NNTP->body( $id );
    my $b = '';
    if ( @$body ) {
      $b = join( '', @$body );
      # Try to extract Signature ... 
      my ($b2, $s) = $b =~ /^(.*)[\s\n]*\n+-{2,3}[ \t\r\f]*\n+(.*)/sm;
      if ( $b2 && $s ) {
        $b = $b2;
        # Made texts links in signature to clickable links
        $s =~ s/(\w+:\/\/\S+)/<a href=\"$1\" target=\"_top\">$1<\/a>/sgm;
        $s =~ s/\s((www|w3)\.[a-z0-9][a-z0-9\.]?\.[a-z]{2,3})\b/<a href=\"http:\/\/$1\/\" target=\"_top\">$1<\/a>/isgm;
        $s =~ s/\s+$//;
        $Article{Signature} = $s;
      }
    } else {
      $b = &message( 'no_body' );
    }
    # Made texts links in body to clickable links
    $b =~ s/(\w+:\/\/\S+)/<a href=\"$1\" target=\"_top\">$1<\/a>/sgm;
    $b =~ s/\s((www|w3)[-a-z_]*\.[a-z0-9][-a-z0-9_\.]?\.[a-z]{2,3})\b/<a href=\"http:\/\/$1\/\" target=\"_top\">$1<\/a>/isgm;
    $Article{Body} = $b;
  }
  $Article{Id} = $id;
  $Article{Header}{subject} = &message( 'no_subject' ) unless $Article{Header}{subject};
  return \%Article;

} # end nntp_get_article();



### Sub print_nntp_error() ###
# &print_nntp_error( request, error ):
# - Description:
# - Arguments  :
# - Return     :
###
sub print_nntp_error ( $$ ) {
  my ($r, $err) = @_;
  $r->log->warn( "${Base} NNTP Error: $err" );
  &print_html_head( $r );
  &print_html_error( $r, "NNTP Error \@ $NewsUrl", $err );
  $r->print
    (
     "<div align=\"center\"><font color=\"red\">", 
     "[<a href=\"",  $r->subprocess_env('SCRIPT_URL'), "\">", &message('try_again'), "</a>]", 
     "</font></div>\n", 
    );
  &print_html_foot( $r );
  return;
} # end print_nntp_error();




# Utilities ---------------------------------------------------------


### Sub get_args() ###
# status = &get_args( request ):
# - Description: Fill in the global hash Args. The args are processed
#   in this order: Cookies, path_info, environment variables, GET then
#   POST args, each arg overriding previous one if already defined.
# - Arguments  : the Apache request
# - Return     : 1=ok, 0=failure
###
sub get_args ( $ ) {
  my $r = shift;

  # Empty Args...
  $Args = {};

  # Get cookies vals
  my %cookies    = CGI::Cookie->parse( $r->header_in('Cookie'));
  my $catchupval = $cookies{$Catchup_Cookie_Name}->value() if $cookies{$Catchup_Cookie_Name};
  $r->log->notice( "Got cookie $Catchup_Cookie_Name: $catchupval" ) if $DEBUG;
  # See action_catchup for settings of cookies
  if ( $catchupval =~ /^(Id)=(\d+),\s*(Date)=(\d+)$/ ) {
    $Args->{catchup_id}   = $2;
    $Args->{catchup_date} = $4;
  }

  # Parse path_info to get the action and such ...
  my $pi = $r->path_info();
  $pi =~ s/^\/*//;
  $Args->{action}      = undef;
  $Args->{action_args} = undef;
  if ( $pi ) {
    my ($action, @rest)  = split( '/', $pi );
    $Args->{action}      = lc( $action ) if $action;
    $Args->{action_args} = \@rest if ( $action && @rest );
  }

  # Get misc useful environment variables. TODO This really needs
  # improvements. If anybody have a good idea on how to do it, thanks!
  my $L         = $r->subprocess_env('LANG') || $r->subprocess_env('USR_LANG') || $USR_LANG;
  $L            = lc( $L );
  $USR_LANG     = $L if ( $LANGS_OK{$L} );
  $Args->{lang} = $USR_LANG;

  # Get args from POST or GET (?args=xxx)
  #$r->log->info( "Reading POST&GET content ..." ) if $DEBUG;
  my %A = ($r->args(), $r->content());
  map{ $Args->{lc($_)} = $A{$_} } keys %A;

  # that's all folks ...
  map{ $r->log->info( "Arg \'$_\': \"", $Args->{$_}, "\"" ) } keys %{$Args} if $DEBUG;



( run in 2.361 seconds using v1.01-cache-2.11-cpan-4ab04211f4c )