in reply to Re: How do a make an IP look up non-greedy?
in thread How do a make an IP look up non-greedy?

Thank-you! Input is Snippet of the logfile: 
10.30.147.23    2009-06-15    09:04:47    1245053087    Help for Hospi
+ces    no-email    no-comment
192.9.200.49    2009-06-15    09:04:50    1245053090    Alzheimer's So
+ciety/Alzheimer Scotland    no-email    no-comment
10.30.117.36    2009-06-15    09:04:50    1245053090    Help for Hospi
+ces    no-email    no-comment
10.30.135.9    2009-06-15    09:04:50    1245053090    NSPCC Childline
+    no-email    no-comment
10.30.198.18    2009-06-15    09:04:59    1245053099    Help for Hospi
+ces    no-email    no-comment

[download]

Current evironment vars? Give me a clue please...... :blush: Tell you what - this is the entire script - this subrouteine is wrapped in a time-lock cookie just to complicate matters! 

#!/usr/bin/perl

 
# Additional security patch added 12-30-2000 in decode
# subroutine.
#
# Added option to block multiple vote attempts using IP
# address. Additional security mods. (02-10-2002)

# Modified IP based multi-vote blocking to allow time based
# blocking as well. (02-16-2002)

# IMPORTANT: This changed the format of the log file. There
# is now a integer number representing the vote time located
# between the human readable date and the first vote response
# field.
#
#------------SCRIPT CONFIGURATION SECTION--------------------

# The script can be called in this manner to provide view without
# voting:

# http://domain.com/cgi-bin/survey/survey.cgi?survey_name=number1


# $DATA_PATH is the FULL system path to the directory where
# your survey data files are stored. Your web server must have
# permission to write to and create files in this directory

  $DATA_PATH= "e:/inetpub/wwwybs/ybsone/cgi-bin/survey/";

# The $DOMAIN must be your site's domain name. 

  $DOMAIN="wwwybs.ybs.com/ybsone";

# $GRAPHICSDIR is the directory under your main html directory
# containing the colored gif files.

  $GRAPHICSDIR="survey";
 
# To prevent people from voting too often, set $USE_COOKIES=1
# HOURS is the NUMBER OF HOURS before the voter can vote
# again. 1 Day=24, 1 Week=168, 1 Month=720 give or take....
# To disable cookies, let $USE_COOKIES=0
#
# WARNING: DO NOT ENABLE COOKIES UNTIL YOU ARE SURE EVERYTHING
# IS WORKING PERFECTLY, OR YOUR DEBUGGING CAN BE SERIOUSLY
# SLOWED DOWN WHILE YOU WAIT FOR THE COOKIE TO EXPIRE. ;-) 

  $USE_COOKIES=1;
  $HOURS=0; # one hour delay between votes

# Set $USE_LOGGING to 1 to turn on log file capture.
# Log format is an ASCII tab delimited file consisting of:
# Visitor's IP address, date, time, responses, e-mail, comments
# Can be easily imported into spreadsheets and databases

  $USE_LOGGING=1;

# If you USE_LOGGING, you can also block multiple votes from
# the same IP address. Just set $BLOCK_IP=1
# If $HOURS (from above) is set to zero, a voter from an IP
# address can only vote once. You can set a minimum time
# between votes by setting $HOURS=1  (as an example) to allow
# a voter from an IP address to vote every hour.

$BLOCK_IP=1;

# IF $SHOW_RESULTS=0 (do not display after voting), be sure
# to set $JUMP_URL to the page the voter should be sent to.
# By default, it sends the voter back to the page they came from.
# When used with SHOW_RESULTS=1, this is the link they can click
# on after viewing the voting.

  $SHOW_RESULTS=1;
  $JUMP_URL="http://wwwybs.ybs.com/ybsone/index.htm";

# These are the cosmetic settings in case you do not like my
# terrible taste in colors! The actual result page layout can
# be found near the bottom of the script.

  $TABLECOLOR="#FFFFFF";
  $HEADINGCOLOR="#FFFFFF";
  $HEADINGFONT="arial,helvetica";
  $BORDERCOLOR="#000080";
  $FONT="arial,helvetica";
  $FONTCOLOR="#000000";

# the script starts for real here....

  &decode_vars;
  &check_files;

  if ($ENV{'REQUEST_METHOD'} eq "POST" && -e $DATA_FILE && -w $DATA_FI
+LE){
   if ($BLOCK_IP == 1 && $USE_LOGGING == 1 && &is_blocked == 1 ){
      &already_voted;
      exit;
   }
   if ($USE_COOKIES == 1){
     $COOKIEVAL=&get_cookie($SURVEY_NAME);
     if (  $COOKIEVAL > time){
      &already_voted;
      exit;
     }
     else{
      $cookie=&set_cookie($SURVEY_NAME,(time + ($HOURS * 3600)),$HOURS
+);
      print "$cookie\n";
     }
   }
   $MODE="VOTE";
   &set_colors;
   &process_file;
   &do_stats;
   if ($SHOW_RESULTS == 1){
     print "Content-type: text/html\n\n";
     $PAGEHEADER=&set_page_header;
     $PAGEFOOTER=&set_page_footer;
     print "$PAGEHEADER\n";
     &display_stats;
     print "$PAGEFOOTER\n";
   }
    else{
      print "Location: $JUMP_URL\n\n";
    }
   exit;
  }

  if ($ENV{'REQUEST_METHOD'} eq "GET" && -e $DATA_FILE){
   $MODE="VIEW";
   &set_colors;
   &process_file;
   &do_stats;
   $PAGEHEADER=&set_page_header;
   $PAGEFOOTER=&set_page_footer;
   print "Content-type: text/html\n\n";
   print "$PAGEHEADER\n";
   &display_stats;
   print "$PAGEFOOTER\n";
   exit;
  }

sub do_stats{
  $oldtag="NONE";
  @groups=();
  foreach $toshow (@list){
   @tags=split(/\|/,$toshow);
   if ($tags[0] ne $oldtag){
     $group=$tags[0];
     push(@groups,$group);
     $total{$group}=0;
     $oldtag = $tags[0];
   }
   $total{$group} = $total{$group} + $questions{$toshow};
  }
}

sub display_stats{
  $oldgroup="NONE";
  $itemcount=0;
  foreach $toshow (@list){
   @tags=split(/\|/,$toshow);
   if ($tags[0] ne $oldgroup){
     if ($oldgroup ne "NONE"){
        $GROUPFOOTER=&set_footer($total{$group});
        print "$GROUPFOOTER\n";
     }
     $group=$tags[0];
     $GROUPHEAD=&set_group_header($title{$group});
     print "$GROUPHEAD\n";
     $oldgroup=$group;
     $itemcount=0;
   }
   if ($total{$group} > 0){
     $pct=int((($questions{$toshow} / $total{$group}  * 100)+.5)) ;
   }
    else{
      $pct=0;
    }
   @qi=split(/\|/,$toshow);
   $giffile=@colors[$itemcount];
   $RESPONSELINE=&set_question($qi[1],$questions{$toshow},$pct, $giffi
+le);
   print "$RESPONSELINE\n";
   $itemcount = $itemcount + 1;
  }
  $GROUPFOOTER=&set_footer($total{$group});
  print "$GROUPFOOTER\n";
}

sub process_file {
  &get_the_lock;
  if ($USE_LOGGING == 1 && $MODE eq "VOTE"){
    $SYSTIME=&sys_date;
    $SYSINT=time;
    $LOG_LINE="$ENV{'REMOTE_ADDR'}\t$SYSTIME\t$SYSINT\t";
    open(LO,">>$LOG_FILE");
  }
  open(IX,"<$DATA_FILE");
  while ($line=<IX>){
    @loga=();
    chop $line;
    @parts=split(/:/,$line);
    $q=$parts[0];
    $n=$parts[1];
    $t=$parts[2];
    @tags=split(/\|/,$line);
    $ti=$tags[0];
    $title{$ti} = $t;
    $titles{$q} = $t;
    if ($fields{$ti} eq $q){ 
     $questions{$q} = $n + 1; 
     @loga=split(/\|/,$q);
     if ($USE_LOGGING == 1 && $MODE eq "VOTE"){$LOG_LINE .= "$loga[1]\
+t";}
    }
      else{ $questions{$q} = $n; }
    push(@list,$q);
  }
  close(IX);
  if ($MODE eq "VOTE"){
    open(IY,">$DATA_FILE");
    foreach $toshow (@list){
      print IY "$toshow:$questions{$toshow}:$titles{$toshow}:\n";
    }
    close(IY);
  }
  if ($USE_LOGGING == 1 && $MODE eq "VOTE"){
    if ($fields{'email'} eq ""){$fields{'email'}="no-email";}
    if ($fields{'comments'} eq ""){$fields{'comments'}="no-comment";}
    $LOG_LINE .= "$fields{'email'}\t$fields{'comments'}";
    print LO "$LOG_LINE\n";
    close(LO);
  }
  &drop_the_lock;
}

sub set_colors{
#this allows for up to 22 responses per question. if you have more, ju
+st 
#continue duplicating the middle two lines of the array below...

  @colors=("blue.gif","red.gif","green.gif","yellow.gif","cherry.gif",
           "navy.gif","pink.gif","black.gif","teal.gif","purple.gif","
+sky.gif",
           "blue.gif","red.gif","green.gif","yellow.gif","cherry.gif",
           "navy.gif","pink.gif","black.gif","teal.gif","purple.gif","
+sky.gif");
}

sub decode_vars
 {
 $i=0;
  if ( $ENV{'REQUEST_METHOD'} eq "GET")
   {
     $temp=$ENV{'QUERY_STRING'};
   }
   else
    {
      read(STDIN,$temp,$ENV{'CONTENT_LENGTH'});
    }
  @pairs=split(/&/,$temp);
  foreach $item(@pairs)
   {
    ($key,$content)=split(/=/,$item,2);
    $content=~tr/+/ /;
    $content=~s/%(..)/pack("c",hex($1))/ge;
    $content=~s/\0//g;
    $key=~s/\0//g;
    $content=~s/\012//gs;
    $content=~s/\015/ /gs;
    $fields{$key}=$content;
   }
  if ($fields{'survey_name'}=~/^([-\@\w.]+)$/){
    $SURVEY_NAME=$fields{'survey_name'};
  }
  else {exit;}
  $fields{'comments'}=~s/\t/ /g;
  $fields{'email'}=&valid_address($fields{'email'});
}

sub valid_address
 {
 my ($testmail) = @_;
  if ($testmail =~/ /)
   { return ""; }
  if ($testmail =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)/ ||
  $testmail !~ /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.([a-zA-Z]{2,4}|[0-9]{1,3})
+(\]?)$/)
   { return ""; }
   else { return $testmail; }
}

sub get_the_lock
{
  if ($MODE ne "VOTE"){return;}
  my $lockfile="$DATA_PATH/$SURVEY_NAME\.lkk";
  local ($endtime);
  $endtime = 40;
  $endtime = time + $endtime;
  while (-e $lockfile && time < $endtime)
   {
    # Do Nothing
   }
   open(LOCK_FILE, ">$lockfile");
}

sub drop_the_lock
{
  if ($MODE ne "VOTE"){return;}
  $lockfile="$DATA_PATH/$SURVEY_NAME\.lkk";
  close(LOCK_FILE);
  unlink($lockfile);
}

sub already_voted{
 print "Content-type: text/html\n\n";
 print<<__END_ALREADY_VOTED__;
 <h2 align=center><FONT FACE="$FONT" COLOR="$FONTCOLOR" size="3">You'v
+e Already Voted for your 2009 Xmas Charity Choice</h2>
 <BR><A HREF="$JUMP_URL"><B>Back to Intranet Home Page</B>

__END_ALREADY_VOTED__
}


#
# This routine takes (name,value,hours,path,domain) as arguments
# to set a cookie.
#
# 0 hours means a current browser session cookie life
#
sub set_cookie() {

  my ($name,$value,$expires) = @_;
  $name=&cookie_scrub($name);
  $value=&cookie_scrub($value);

  $expires=$expires * 3600;
  $expires=int($expires);

  my $expire_at=&cookie_date($expires);
  my $namevalue="$name=$value";

  my $COOKIE="";

  if ($expires != 0) {
     $COOKIE= "Set-Cookie: $namevalue; path=$path; expires=$expire_at;
+ ";
  }
   else {
     $COOKIE= "Set-Cookie: $namevalue; ";   #current session cookie if
+ 0
   }
  return $COOKIE;
}

#
# This routine removes cookie of (name) by setting the expiration
# to a date/time GMT of (now - 24hours)
#
sub remove_cookie() {
  my ($name) = @_;
  $name=&cookie_scrub($name);
  my $value="";
  my $cookie="";
  my $expires=&cookie_date(-86400);
  my $namevalue="$name=$value";
  my $COOKIE= "Set-Cookie: $namevalue; expires=$expires; ";
  return $COOKIE;
}


#
# given a cookie name, this routine returns the value component
# of the name=value pair
# a returned value of 0 means no cookie
#
sub get_cookie() {
  my ($name) = @_;
  $name=&cookie_scrub($name);
  my $temp=$ENV{'HTTP_COOKIE'};
  @pairs=split(/\; /,$temp);
  foreach my $sets (@pairs) {
    my ($key,$value)=split(/=/,$sets);
    $clist{$key} = $value;
  }
  if ($clist{$name} eq "") {$clist{$name}="0";}
  my $retval=$clist{$name};
  return $retval;
}

#
# this routine accepts the number of seconds to add to the server
# time to calculate the expiration string for the cookie. Cookie
# time is ALWAYS GMT!
#
sub cookie_date() {
  my ($seconds) = @_;
  my %mn = ('Jan','01', 'Feb','02', 'Mar','03', 'Apr','04',
            'May','05', 'Jun','06', 'Jul','07', 'Aug','08',
            'Sep','09', 'Oct','10', 'Nov','11', 'Dec','12' );
  my $sydate=gmtime(time+$seconds);
  my ($day, $month, $num, $time, $year) = split(/\s+/,$sydate);
  my    $zl=length($num);
  if ($zl == 1) { 
    $num = "0$num";
  }
  my $retdate="$day $num-$month-$year $time GMT";
  return $retdate;
}


#
# don't allow = or ; as valid elements of name or data
#
sub cookie_scrub() {
  my($retval) = @_;
  $retval=~s/\;//g;
  $retval=~s/\=//g;
  return $retval;
}

#
# check to see if the IP of this client has been logged.
# if so, return 1 to indicate client should be blocked.
# only called if $USE_LOGGING and $BLOCK_IP are set to 1.
# added 02/10/2002
#
# Modified on 02/16/2002 so that if $HOURS are not equal
# to 0, you can control the time between votes based on
# IP address the same way as with cookies.
#

sub is_blocked{
 my $current_time=time;
 my @solog=();
 open(OLOGS,"<$LOG_FILE");
 my @logs=<OLOGS>;
 close(OLOGS);
 my $lcounter=@logs;
 for ($lcounter; $lcounter >= 0; $lcounter--){
   if (-1 > index $logs[$lcounter], $ENV{'REMOTE_ADDR'} ){
  # if ( $logs[$lcounter]=~/^$ENV{'REMOTE_ADDR'}/){
     if ($HOURS == 0){
       return 1;
     }
     @solog=split(/\t/,@logs[$lcounter]);
     if ( ($solog[3] + ($HOURS * 3600)) > $current_time ){
       return 1;
     }
   }
 }
 return 0;
}


sub sys_date{
 my %mn = ('Jan','01', 'Feb','02', 'Mar','03', 'Apr','04',
        'May','05', 'Jun','06', 'Jul','07', 'Aug','08',
        'Sep','09', 'Oct','10', 'Nov','11', 'Dec','12' );
 my $sydate=localtime(time);
 my ($day, $month, $num, $time, $year) = split(/\s+/,$sydate);
 my $zl=length($num);
    if ($zl == 1) { $num = "0$num";}
 my $retval="$year\-$mn{$month}\-$num\t$time";
 return $retval;
}

sub check_files{
  $DATA_FILE="$DATA_PATH/$SURVEY_NAME\.srv";
  $LOG_FILE="$DATA_PATH/$SURVEY_NAME\.log";
  if ( !-e $DATA_FILE){
   print "Content-type: text/html\n\n Data File is Missing!\n";
   exit;
  }
  if ( !-w $DATA_FILE){
   print "Content-type: text/html\n\n Data File Cannot be Written to!\
+n";
   exit;
  }
  if ( !-e "$LOG_FILE" && $USE_LOGGING == 1){
   open(OP,">>$LOG_FILE");
   close(OP);
  }
  if ( !-w "$DATA_PATH/$SURVEY_NAME\.log" && $USE_LOGGING == 1){
   print "Content-type: text/html\n\n Log File Cannot be Written to!\n
+";
   exit;
  }
}

######################## COSMETIC SECTION ##########################
#
# The following subroutines contain the HTML text (and some logic
# so be careful editing!) that is presented when viewing the survey
# results.
#

sub set_page_header{
 my $PAGEHEAD=<<__END_PAGE_HEAD__;
 
 <BODY BGCOLOR="#FFFFFF">
 <CENTER>
 <TABLE BORDER=0 BGCOLOR="$BORDERCOLOR" WIDTH="100%">
  <TR>
  <TD ALIGN=CENTER>
 <TABLE BORDER=0 BGCOLOR="$TABLECOLOR" WIDTH="100%">
  <TR>
  <TD COLSPAN=4>
  <CENTER>
  <FONT FACE="$HEADINGFONT" COLOR="#000080">
   <FONT SIZE=5>2009 Xmas Charity Poll</FONT>
  </FONT>
  <CENTER>
 </TR>
__END_PAGE_HEAD__
 return $PAGEHEAD;
}
#below can be added back in to line 509 if ever desired
#  <CENTER>
#  <FONT FACE="$HEADINGFONT" COLOR="$HEADINGCOLOR">
#   <FONT SIZE=5>BigNoseBird Survey Script</FONT>
#  <BR>
#  <FONT FACE="$FONT" COLOR="$FONTCOLOR">
#   <B>Click</B>
#  <A HREF="http://bignosebird.com/carchive/survey.shtml"><B>HERE</B><
+/A>
#  <B>to Download!</B>
#  </FONT>
#  <CENTER>
#  <P>

sub set_group_header{
 my ($GROUP_HEADING)=@_;
 my $GROUP_HEADER=<<__END_GROUP_HEADER__;

 <TR>
 <TD COLSPAN=4 ALIGN=LEFT bgcolor="#000080">
  <FONT FACE="$HEADINGFONT" COLOR="$HEADINGCOLOR"><B>$GROUP_HEADING</B
+></FONT>
 </TD>
 </TR> 
 <TR>
  <TD WIDTH="60%"><FONT FACE="$FONT" COLOR="$FONTCOLOR" size="2"><b>Re
+sponse</b></TD>
  <TD WIDTH="10%" ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR" si
+ze="2"><b>Number</b></TD>
  <TD WIDTH="10%" ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR" si
+ze="2"><b>Percent</b></TD>
  <TD WIDTH="20%"><FONT FACE="$FONT" COLOR="$FONTCOLOR" size="2"><b>Gr
+aph</b></TD>
 </TR>

__END_GROUP_HEADER__
return $GROUP_HEADER;
}

sub set_question{
 my ($respitem,$count,$pct,$giffile) = @_;
 my $factor = $pct * 2.50;
 my $SCALE=int($factor);
 my $RESPONSE=<<__END_RESPONSE_LINE__;

<TR>
  <TD VALIGN=TOP><FONT FACE="$FONT" COLOR="$FONTCOLOR"><small>$respite
+m</small></FONT></TD>
  <TD VALIGN=TOP ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR"><sm
+all>$count</small></FONT></TD>
  <TD VALIGN=TOP ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR"><sm
+all>$pct\%</small></FONT></TD>
  <TD><IMG SRC="http://$DOMAIN/$GRAPHICSDIR/$giffile" HEIGHT=5 WIDTH=$
+SCALE BORDER=0></TD>
</TR>

__END_RESPONSE_LINE__
 return $RESPONSE;
}

sub set_footer{
 my ($tot) = @_;
 my $FOOTGROUP=<<__END_GROUP_FOOTER__;

 <TR>
 <TD COLSPAN=4 ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR"><smal
+l>Total Number of Responses: $tot</small><br></FONT></TD>
 </TR>

__END_GROUP_FOOTER__
return $FOOTGROUP;
}

sub set_page_footer{
my $PAGEFOOT=<<__END_PAGE_FOOT__;
 </TD>
 </TR>
 <TR>
 <TD COLSPAN=4 ALIGN=CENTER>
  <FONT FACE="$FONT" COLOR="#000080" size="2">The top 3 chosen will be
+ asked to present to the Trustees and the decision will be announced 
+as soon as possible<br>
  <A HREF="$JUMP_URL"><B>Back to Intranet Home Page</B>
  </FONT>
 </TD>
 </TR>
</TABLE>
 </TD>
 </TR>
</TABLE>
</CENTER>
__END_PAGE_FOOT__
 return $PAGEFOOT;
}

[download]
Never knowingly obfuscated

Replies are listed 'Best First'.
Re^3: How do a make an IP look up non-greedy?
by Marshall (Canon) on Jun 16, 2009 at 12:50 UTC
    Here is an idea...
    This gets the first 4 space separated things and the 5th thing is left all together. Parsing that last thing will be the most difficult.

    #!usr/bin/perl -w
use strict;

while ( my $line =(<DATA>) )
{

  my @tokens = my ($ip,$date,$time,$number,$text)= 
     $line =~ m/^(\S+)\s*(\S+)\s*(\S+)\s*(\S+)\s*(.*)$/;
  print "Line =\t$line";
  foreach my $token (@tokens)
  {
     print "\t$token\n";
  }
}
###########   Output  ###################
#Line =    10.30.147.23    2009-06-15    09:04:47    1245053087    Hel
+p for Hospices    no-email    no-comment
#    10.30.147.23
#    2009-06-15
#    09:04:47
#    1245053087
#    Help for Hospices    no-email    no-comment
#Line =    192.9.200.49    2009-06-15    09:04:50    1245053090    Alz
+heimer's Society/Alzheimer Scotland    no-email    no-comment
#    192.9.200.49
#    2009-06-15
#    09:04:50
#    1245053090
#    Alzheimer's Society/Alzheimer Scotland    no-email    no-comment
#Line =    10.30.117.36    2009-06-15    09:04:50    1245053090    Hel
+p for Hospices    no-email    no-comment
#    10.30.117.36
#    2009-06-15
#    09:04:50
#    1245053090
#    Help for Hospices    no-email    no-comment
#Line =    10.30.135.9    2009-06-15    09:04:50    1245053090    NSPC
+C Childline    no-email    no-comment
#       10.30.135.9
#    2009-06-15
#    09:04:50
#    1245053090
#    NSPCC Childline    no-email    no-comment
#Line =    10.30.198.18    2009-06-15    09:04:59    1245053099    Hel
+p for Hospices    no-email    no-comment
#    10.30.198.18
#    2009-06-15
#    09:04:59
#    1245053099
#    Help for Hospices    no-email    no-comment
__DATA__
10.30.147.23    2009-06-15    09:04:47    1245053087    Help for Hospi
+ces    no-email    no-comment
192.9.200.49    2009-06-15    09:04:50    1245053090    Alzheimer's So
+ciety/Alzheimer Scotland    no-email    no-comment
10.30.117.36    2009-06-15    09:04:50    1245053090    Help for Hospi
+ces    no-email    no-comment
10.30.135.9    2009-06-15    09:04:50    1245053090    NSPCC Childline
+    no-email    no-comment
10.30.198.18    2009-06-15    09:04:59    1245053099    Help for Hospi
+ces    no-email    no-comment

    [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom