view release on metacpan or  search on metacpan

acebrowser/cgi-bin/generic/pic  view on Meta::CPAN

  umask 002;  # want this writable by group
  my ($pic,$picroot) = @{Configuration()->Pictures};

  if ($ENV{MOD_PERL} && Apache->can('request')) { # we have apache, so no reason not to take advantage of it
    my $r = Apache->request;
    my $subr = $r->lookup_uri($pic ."/");
    $picroot = $subr->filename if $subr;
  }

  mkpath (["$picroot/$path"],0,0777) || AceError("Can't create directory to store image in")
    unless -d "$picroot/$path";

  # should be some sort of state variable?
  $safe_name .= "." . param('click') if param('click');
  $safe_name .= ".start=$map_start,stop=$map_stop" if $has_coords;
  $safe_name .= ".gif";
  my $image_file = "$picroot/$path/$safe_name";
  my $image_path = "$pic/$path/$safe_name";

  # get the parameters for the image generation
  my @clicks =  map { [ split('-',$_) ] } split(',',param('click'));

  my @param = (-clicks=>\@clicks);
  if ($class =~ /Map/) {
    push(@param,(-dimensions=>[WIDTH,HEIGHT]));
    push(@param,(-coords=>[param('map_start'),param('map_stop')])) if $has_coords;
  }


  my ($gif,$boxes) = $obj ? $obj->asGif(@param) : ();

  unless (-e $image_file && -M $image_file < 0) {
    local(*F);
    open (F,">$image_file") || AceError("Can't open image file $image_file for writing: $!\n");
    print F $gif || unpack("u",ERROR_GIF);
    close F;
  }

  my $u = Url('pic') . "?" . query_string();
  $u .= param('click') ? ',' : '&click=';

  print
    img({-src   => $image_path,
	 -name  => 'theMapImg',
	 -border=> 0,
	 # this is for Internet Explorer, has no effect on Netscape!
	 -onClick=>"send_click(event,'$u')",
	 -usemap=>'#theMap',
	 -isMap=>undef}),
    ;

  print_map($name,$class,$boxes);
}

sub print_map {
    my ($name,$class,$boxes) = @_;
    my @lines;
    my $old_clicks = param('click');
    Delete('click');

    # Collect some statistics in order to inhibit those features
    # that are too dense to click on sensibly.
    my %centers;
    foreach my $box (@$boxes) {
	my $center = center($box->{'coordinates'});
	$centers{$center}++;
    }

    my $user_agent =  http('User_Agent');
    my $modern = $user_agent=~/Mozilla\/([\d.]+)/ && $1 >= 4;

    my $max = Configuration()->Max_in_column || 100;

    foreach my $box (@$boxes) {
	my $center = center($box->{'coordinates'});
	next if $centers{$center} > $max;
	
	my $coords = join(',',@{$box->{'coordinates'}});
	(my $jcomment = $box->{'comment'} || "$box->{class}:$box->{name}" )
	    =~ s/'/\\'/g; # escape single quotes for javascript

	CASE :
	{

	    if ($box->{name} =~ /gi\|(\d+)/ or 
		($box->{class} eq 'System' and $box->{'comment'}=~/([NP])ID:g(\d+)/)) {
		my($db) = $2 ? $1 : 'n';
		my($gid) = $2 || $1;
		my $url = NCBI . "?db=$db&form=1&field=Sequence+ID&term=$gid";
                push(@lines,qq(<AREA shape="rect"
                                     onMouseOver="return s(this,'$jcomment')"
                                     coords="$coords"
                                     href="$url">));
		last CASE;
	    }

	    last CASE if $box->{class} eq 'System';

	    if ($box->{class} eq 'BUTTON') {
		my ($c) = map { "$_->[0]-$_->[1]" } [ map { 2+$_ } @{$box->{coordinates}}[0..1]];
		my $clicks = $old_clicks ? "$old_clicks,$c" : $c;
                my $url = Url('pic',query_string() . "&click=$clicks");
                push(@lines,qq(<AREA shape="rect"
                                     coords="$coords"
                                     onMouseOver="return s(this,'$jcomment')"
                                     target="_self"
                                     href="$url">));
		last CASE;
	    }
	    my $n = escape($box->{'name'});
	    my $c = escape($box->{'class'});
	    my $href = Object2URL($box->{'name'},$box->{'class'});
            push(@lines,qq(<AREA shape="rect"
                                 onMouseOver="return s(this,'$jcomment')"
                                 coords="$coords"
                                 href="$href">));
	}
    }

    # Create default handling.  Bad use of javascript, but can't think of any other way.
    my $url = Url('pic', query_string());