| #!/usr/bin/perl |
| # Copyright (c) 2006-2007 Eclipse Foundation, made available under EPL v1.0 |
| # Contributors Ward Cunningham, Bjorn Freeman-Benson |
| |
| use strict; |
| use Sys::Hostname; |
| require 'siteconfig'; |
| use GD::Simple; |
| |
| print "Content-type: image/png\n"; |
| print "Cache-Control: post-check=3600,pre-check=43200\n"; |
| print "Cache-Control: max-age=86400\n"; |
| print "Expires: Mon, 01 Jan 2099 05:00:00 GMT\n"; |
| print "\n"; |
| |
| my (%y, %x, %counts); |
| our $site; |
| my $prog = "/dash/commits/web-api/commit-active-projects.php"; |
| my $args; |
| |
| my %data; |
| my %dates; |
| my @dates; |
| my %projects; |
| my @projects; |
| my $log; |
| my $_max; |
| my $_min; |
| my $theproject; |
| |
| my $var = 'top|project|company'; |
| |
| $_ = $ENV{QUERY_STRING}; |
| ($args) = /((($var)=[A-Za-z0-9_.-]+&?)+)/; |
| |
| $args =~ /project=([A-Za-z0-9_.-]+)/; |
| $theproject = $1; |
| |
| query(); |
| report( $theproject ); |
| |
| sub query { |
| |
| my $sockaddr = 'S n a4 x8'; |
| my $AF_INET = 2; |
| my $SOCK_STREAM = 1; |
| chop(my $hostname = hostname()); |
| |
| my ($name, $aliases, $proto) = getprotobyname('tcp'); |
| my ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); |
| my ($name, $aliases, $type, $len, $thataddr) = gethostbyname($site); |
| |
| my $this = pack($sockaddr, $AF_INET, 0, $thisaddr); |
| my $that = pack($sockaddr, $AF_INET, 80, $thataddr); |
| |
| socket (S, $AF_INET, $SOCK_STREAM, $proto) || die "socket: $!"; |
| bind(S, $this) || die "bind: $!"; |
| connect(S, $that) || die "connect: $!"; |
| |
| select(S); |
| $| = 1; |
| print S "GET /$prog?$args\r\n"; |
| |
| select(STDOUT); |
| while (<S>) { |
| if (/^#/) { |
| $log .= "$_<br>"; |
| next; |
| } |
| chomp; |
| if( $_max && $_min ) { |
| my ($project,$date,$count) = split /\t/; |
| $data{$project}{$date} = $count; |
| $dates{$date} = 1; |
| $projects{$project} = 1; |
| } else { |
| $_min = $_ if $_max; |
| $_max = $_ unless $_max; |
| } |
| } |
| } |
| |
| sub report { |
| my $project = shift; |
| my $dt = $_min; |
| while( $dt <= $_max ) { |
| $dates{$dt} = 1; |
| if( ($dt % 100) >= 12 ) { |
| $dt = (int( $dt / 100 ) + 1) * 100 + 1; |
| } else { |
| $dt++; |
| } |
| } |
| @dates = keys %dates; |
| @projects = keys %projects; |
| @dates = sort @dates; |
| @projects = sort @projects; |
| |
| compute_activity( $project ); |
| |
| # create a new image |
| my @ys = split( /,/, $data{$project}{LINEDATA} ); |
| my $width = 8 * scalar( @ys ); |
| my $img = GD::Simple->new($width,20); |
| $img->transparent(); |
| $img->clear(); |
| $img->fgcolor(100,100,100); |
| $img->bgcolor(200,200,200); |
| |
| my $x = 0; |
| foreach my $y ( @ys ) { |
| $img->rectangle( $x, 20-$y, $x+6, 20); |
| $x += 8; |
| } |
| |
| # convert into png data |
| print $img->png; |
| } |
| |
| sub compute_activity { |
| my $project = shift; |
| my @ys; |
| |
| # get the data array |
| my $seenany = 0; |
| foreach my $date ( @dates ) { |
| if( $seenany || defined( $data{$project}{$date} ) ) { |
| my $d = $data{$project}{$date}; |
| $d = 0 unless $d; |
| push @ys, $d; |
| $seenany = 1; |
| } |
| } |
| my @xs = @ys; |
| |
| # scale data so that maximum is max bar height |
| my @zs = scale( \@ys, 20.0 ); |
| |
| # scale data so that median is mid-point bar height |
| my $clip = max( \@ys ); |
| for( my $idx = 0; $idx < 4; $idx++ ) { |
| my $avg = average( \@zs, \@xs ); |
| last if( $avg >= 7.0 && $avg <= 13.0 ); |
| $clip *= $avg / 10.0; |
| @ys = clip( \@xs, $clip ); |
| @zs = scale( \@ys, 21.0 ); |
| } |
| |
| # ensure that non-zero values are different than zeros |
| @zs = nonzero( \@zs, \@xs ); |
| |
| $data{$project}{LINEDATA} = join( ",", @zs ); |
| } |
| |
| sub scale { |
| my $ins = shift; |
| my $maxout = shift; |
| my @outs; |
| my $maxin = 0; |
| foreach my $v ( @$ins ) { |
| $maxin = $v if $v > $maxin; |
| } |
| return @$ins unless $maxin; |
| my $scale = $maxout / $maxin; |
| foreach my $v ( @$ins ) { |
| my $d = int( $v * $scale ); |
| push @outs, $d; |
| } |
| return @outs; |
| } |
| |
| sub clip { |
| my $ins = shift; |
| my $max = shift; |
| my @outs; |
| foreach my $v ( @$ins ) { |
| my $d = $v; |
| $d = $max if $d > $max; |
| push @outs, $d; |
| } |
| return @outs; |
| } |
| |
| sub max { |
| my $ins = shift; |
| my $max = 0; |
| foreach my $v ( @$ins ) { |
| $max = $v if $v > $max; |
| } |
| return $max; |
| } |
| |
| sub average { |
| my $ins = shift; |
| my $orig = shift; |
| my $sum = 0; |
| my $cnt = 0; |
| for( my $i = 0; $i < @$ins; $i++ ) { |
| my $v = $ins->[$i]; |
| my $v0 = $orig->[$i]; |
| if( $v0 ) { |
| $sum += $v; |
| $cnt++; |
| } |
| } |
| return 0 unless $cnt; |
| return $sum / $cnt; |
| } |
| |
| sub nonzero { |
| my $ins = shift; |
| my $orig = shift; |
| my @outs; |
| for( my $i - 0; $i < @$ins; $i++ ) { |
| my $v = $ins->[$i]; |
| my $v0 = $orig->[$i]; |
| $v = 2 if $v0 && !$v; |
| $v = 1 if !$v0; |
| push @outs, $v; |
| } |
| return @outs; |
| } |