-
Notifications
You must be signed in to change notification settings - Fork 0
/
gbrowse.pls.new
executable file
·3591 lines (3071 loc) · 117 KB
/
gbrowse.pls.new
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#!perl
use Config;
use File::Basename qw(&basename &dirname);
use File::Spec;
use FindBin '$Bin';
use Cwd;
my %OPTIONS;
if (open F,"$Bin/../GGB.def") {
while (<F>) {
next if /^\#/;
chomp;
$OPTIONS{$1} = $2 if /^(\w+)\s*=\s*(.+)/;
}
close F;
}
$OPTIONS{CONF} ||= '/usr/local/apache/conf';
my $dir = dirname($0);
$file = shift || File::Spec->catfile($dir,basename($0, '.PL','.PLS'));
open OUT,">$file" or die "Can't create $file: $!";
print "Extracting $file (with variable substitutions)\n";
my $startperl = $Config{startperl} ne '#!perl'
? $Config{startperl}
: "#!$Config{perlpath}";
print OUT <<"!GROK!THIS!";
$startperl -w
###################################################################
# Non-modperl users should change this variable if needed to point
# to the directory in which the configuration files are stored.
#
\$CONF_DIR = '$OPTIONS{CONF}/gbrowse.conf';
#
###################################################################
\$VERSION = $OPTIONS{VERSION};
\$BIOGRAPHICS_VERSION = $OPTIONS{BIOGRAPHICS_VERSION};
!GROK!THIS!
print OUT "use lib '$OPTIONS{LIB}';\n" if defined $OPTIONS{LIB};
# In the following, perl variables are not expanded during extraction.
print OUT <<'!NO!SUBS!';
# $Id: gbrowse.PLS,v 1.119.4.57.2.59.2.76 2008/05/16 00:28:42 lstein Exp $
use strict;
use Bio::Graphics;
use Bio::Graphics::Browser;
use Bio::Graphics::Browser::Util;
use Bio::Graphics::Browser::PluginSet;
use Bio::Graphics::Browser::UploadSet;
use Bio::Graphics::Browser::RemoteSet;
use Bio::Graphics::Browser::PageSettings;
use Digest::MD5 'md5_hex';
use File::Path 'mkpath';
use Text::Tabs;
use Text::Shellwords;
use File::Basename 'basename','dirname';
use File::Spec;
use Carp qw(:DEFAULT croak);
use CGI qw(:standard unescape escape escapeHTML center *table *dl *TR *td);
use CGI::Toggle;
use CGI::Cookie;
use vars qw($CONFIG $MAX_SEGMENT $DEFAULT_SEGMENT
$HEADER $HTML $UA $VERSION $BIOGRAPHICS_VERSION $CONF_DIR
%PLUGINS $PLUGINS $UPLOADED_SOURCES $REMOTE_SOURCES
$PRESETS $HAVE_SVG
%OBJECT_CLASSES %PLUGIN_NAME2LABEL );
# if you change the zoom/nav icons, you must change this as well.
use constant MAG_ICON_HEIGHT => 20;
use constant MAG_ICON_WIDTH => 8;
# had-coded values for segment sizes
# many of these can be overridden by configuration file entries
use constant MAX_SEGMENT => 1_000_000;
use constant MIN_SEG_SIZE => 20;
use constant TINY_SEG_SIZE => 2;
use constant EXPAND_SEG_SIZE => 5000;
use constant TOO_MANY_SEGMENTS => 5_000;
use constant TOO_MANY_FEATURES => 100;
use constant TOO_MANY_REFS => TOO_MANY_FEATURES;
use constant DEFAULT_SEGMENT => 100_000;
use constant DEFAULT_REGION_SIZE => 100_000_000;
use constant OVERVIEW_RATIO => 0.9;
use constant ANNOTATION_EDIT_ROWS => 25;
use constant ANNOTATION_EDIT_COLS => 100;
use constant URL_FETCH_TIMEOUT => 5; # five seconds max!
use constant URL_FETCH_MAX_SIZE => 1_000_000; # don't accept any files larger than 1 Meg
use constant MAX_KEYWORD_RESULTS => 1_000; # max number of results from keyword search
use constant DEFAULT_RANGES => q(100 500 1000 5000 10000 25000 100000 200000 400000);
use constant DEFAULT_FINE_ZOOM => '10%';
use constant GBROWSE_HELP => '/gbrowse';
use constant DEFAULT_PLUGINS => 'FastaDumper RestrictionAnnotator SequenceDumper';
use constant CHECKBOX_COLUMNS => 4;
# if true, turn on surrounding rectangles for debugging the image map
use constant DEBUG => 0;
use constant DEBUG_EXTERNAL => 0;
use constant DEBUG_PLUGINS => 0;
use constant GLOBAL_TIMEOUT => 60; # 60 seconds to failure unless overridden in config
local $CGI::USE_PARAM_SEMICOLONS = 1;
$HAVE_SVG = eval {require GD::SVG; 1};
# IMPORTANT DATA STRUCTURES
# $SETTINGS (also called $page_settings): hash reference containing state information
# keys:
# name name of a landmark to search for (e.g. keyword search)
# ref sequence landmark reference ID (once found)
# start start of range relative to ref
# stop stop of range relative to ref
# source symbolic name of database/configuration to use
# id unique cookie-based ID for this user
# plugin last accessed plugin
# ks position of key (beneath or between)
# tracks array ref which has one element for each track on the
# display. The value of each element indicates what
# track to display in that position using the configuration
# key code. For example: [HMM,BAB,GB]
# means display the "HMM", "BAB" and "GB" features in that
# order. Uploaded feature data is named "UPLOAD",
# External URL tracks are indicated using the URL of the data.
# features hash ref which has one element for each feature type.
# Its values are hashrefs with subkeys {visible} and {options}.
# A true value in {visible} indicates that the feature is active.
# The values of {options} are integers with the following meaning:
# 0=auto, 1=force no bump, 2=force bump, 3=force label.
# ins Show instructions
# head Show header and footer
# h_feat Search term(s) for hiliting
# h_region Region to hilight
# q A search term passed in the URL -- there may be multiple ones
# $CONFIG
# This is a global Bio::Graphics::Browser object. It contains information on
# all the configuration files for this browser and provides access to the various
# settings within the configuration file.
BEGIN {
eval "use Apache";
warn <<END if Apache::DBI->can('connect_on_init');
WARNING: APACHE::DBI DETECTED.
THIS WILL CAUSE THE GFF DUMP TO FAIL INTERMITTENTLY.
THIS SCRIPT DOES NOT BENEFIT FROM APACHE::DBI
END
;
};
$HEADER=0;
$HTML=0;
version_warning();
$ENV{PATH} = '/bin:/usr/bin:/usr/local/bin';
$CONF_DIR = conf_dir($CONF_DIR); # conf_dir() is exported from Util.pm
## CONFIGURATION & INITIALIZATION ################################
# preliminaries -- read and/or refresh the configuration directory
$CONFIG = open_config($CONF_DIR); # open_config() is exported from Util.pm
## PAGE SETTINGS #################################################
#
# Recover a hashref which contains page-specific settings
# (this involves reading a cookie or possibly a database record
# in some future implementation)
my ($page_settings,$session) = page_settings($CONFIG); # WARNING: this may cause a redirect and exit
my $source = $CONFIG->source;
my $cookie = CGI::Cookie->new(-name => $CGI::Session::NAME,
-value => $session->id,
-path => url(-absolute=>1),
-expires => $CONFIG->remember_source_time);
my $cookies;
if (param('reset')) {
$cookies = reset_cookies($page_settings);
} else {
$cookies = [$cookie];
}
if (handle_asynchronous_events($page_settings)) {
print CGI::header(-status=>'204 No Content');
$session->session->flush;
exit 0;
}
if (my $label = param('configure_track')) {
track_config($page_settings,$label);
exit 0;
}
### PLUGINS #################################################################
my @plugin_path = "$CONF_DIR/plugins";
unshift @plugin_path,shellwords($CONFIG->setting('plugin_path'))
if $CONFIG->setting('plugin_path');
$PLUGINS = $PLUGINS{$source} ||= Bio::Graphics::Browser::PluginSet->new($CONFIG,$page_settings,@plugin_path);
$PLUGINS->configure(open_database(),$page_settings,$session);
my $plugin_type = ''; # avoid uninit variable warning
$plugin_type = $PLUGINS->plugin(param('plugin'))->type if param('plugin') && $PLUGINS->plugin(param('plugin'));
my $plugin_action = param('plugin_action') || '';
warn "plugin_action = $plugin_action" if DEBUG_PLUGINS;
# for activating the plugin by URL
if (param('plugin_do')) {
$plugin_action = $CONFIG->tr(param('plugin_do')) || $CONFIG->tr('Go');
}
# For uploaded files
$UPLOADED_SOURCES = Bio::Graphics::Browser::UploadSet->new($CONFIG,$page_settings);
$REMOTE_SOURCES = Bio::Graphics::Browser::RemoteSet->new($CONFIG,$page_settings);
## GETTING THE SEGMENT ######################################################
## but only if we have started a search! ##
my $is_search = is_search($page_settings);
my $features = $is_search ? get_features($page_settings) : [];
if ($plugin_action eq $CONFIG->tr('Find') && param('plugin')) {
do_plugin_find($page_settings,
param('plugin'),
$features) or ($plugin_action = 'Configure'); #reconfigure
}
elsif (!@$features && $page_settings->{name} && $is_search) {
@$features = do_keyword_search($page_settings->{name});
@$features = do_plugin_autofind($page_settings,$page_settings->{name})
if !@$features; # last resort
}
my $segments = features2segments($features);
my @segments = @$segments;
# tell the plugins which segments are in play
$PLUGINS->set_segments(\@segments);
$REMOTE_SOURCES->set_sources([param('eurl')]) if param('eurl');
###############################################################################################
# SETTINGS FOR UPLOADED FILES
my ($file_action) = grep {/^modify\./} param();
(my $file = $file_action) =~ s/^modify\.// if $file_action;
###############################################################################################
## DUMPS ######################################################################################
###############################################################################################
# Check to see whether one of the plugin dumpers was invoked. We have to do this first
# before printing the header because the plugins are responsible for generating the header.
# NOTE THE EXIT 0 HERE IF THE DUMP IS SUCCESSFUL!
if ((@segments||param('plugin_config')) && $plugin_action eq $CONFIG->tr('Go') && $plugin_type eq 'dumper') {
do_plugin_header(param('plugin'),$page_settings,$cookie);
do_plugin_dump(param('plugin'),$segments[0],$page_settings) && exit 0
}
elsif ($plugin_action eq $CONFIG->tr('Go') &&
$plugin_type eq 'dumper'
&& $PLUGINS->plugin(param('plugin'))->verb eq ($CONFIG->tr('Import')||'Import') ) {
do_plugin_header(param('plugin'),
$page_settings,
$cookie);
do_plugin_dump(param('plugin'),
$segments[0],
$page_settings) && exit 0
}
###############################################################################################
## HANDLING FILE DOWNLOADS ######################################################################
# This gets called if the user wants to download his annotation data
if (my $to_download = (param($CONFIG->tr('Download_file')) ||
($file_action && param($file_action) eq $CONFIG->tr('Download_file')) && $file)) {
warn "FILE DOWNLOAD, download = $to_download" if DEBUG;
print_header(-cookie => $cookie,
-attachment => $to_download,
-type => 'application/octet-stream');
print_uploaded_file_features($page_settings,$to_download);
exit 0;
}
warn "TRACKS = @{$page_settings->{tracks}}" if DEBUG;
load_plugin_annotators($page_settings);
warn "ANNOTATOR TRACKS = @{$page_settings->{tracks}}" if DEBUG;
adjust_tracks($page_settings);
auto_open($page_settings,$features) if @$features;
warn "ADJUSTED TRACKS = @{$page_settings->{tracks}}" if DEBUG;
# NOTE: we may exit out on the next statement if the user wants to download a previously-
# uploaded file
handle_uploads($page_settings) || exit 0 unless $CONFIG->section_setting('upload_tracks') eq 'off';
## UPDATING THE PERSISTENT SETTINGS##############################################################
print_header(-cookie => $cookies,
-charset=>$CONFIG->tr('CHARSET')
);
if (request_method eq 'HEAD') {exit 0}
my $description = $CONFIG->setting('description');
my $segment;
## STARTING THE PAGE ############################################################################
my $divisor = $CONFIG->setting(general=>'unit_divider') || 1;
my $title;
if ($divisor == 1) {
$title = @segments == 1 ?
"$description: ".$segments[0]->seq_id.":".$segments[0]->start.'..'.$segments[0]->end
: $description;
} else {
if (@segments == 1) {
my $seg_start = $CONFIG->unit_label($segments[0]->start);
my $seg_end = $CONFIG->unit_label($segments[0]->end);
$title = "$description: ".$segments[0]->seq_id.":".$seg_start.'..'.$seg_end;
} else {
$title = $description;
}
}
# PAGE STARTS HERE
my $alert = param('reset') ? $CONFIG->tr('Options_reset')
: $page_settings->{upgraded} ? $CONFIG->tr('Options_updated')
: '';
print_top($title,scalar param('reset'),$alert);
## HANDLE TRACK SETTINGS #######################################################
if ((param('set_options') || param($CONFIG->tr('Set_options')) || param('revert'))
&& !param($CONFIG->tr('Cancel'))
&& !param($CONFIG->tr('Redisplay'))
&& !param('adjust_one_track')
) {
set_track_options($page_settings);
}
## HANDLE HELP PAGE #######################################################
elsif (param('help')) {
help(param('help'),$CONFIG->setting('help')||GBROWSE_HELP,$page_settings);
}
## HANDLE PLUGIN ABOUT PAGE #####################################################
elsif ($plugin_action eq $CONFIG->tr('About')) {
do_plugin_about(param('plugin'));
}
## HANDLE PLUGIN CONFIGURATION####################################################
elsif ($plugin_action eq $CONFIG->tr('Configure')) {
do_plugin_configure(param('plugin'));
}
elsif ($plugin_action eq $CONFIG->tr('Go') && $plugin_type=~/^(finder|annotator|highlighter)$/i) {
do_plugin_configure(param('plugin'));
}
## MAIN DISPLAY
else {
my $header = $CONFIG->header;
print $header || h1($description) if $page_settings->{head};
main_display($segments,$features,$page_settings);
}
print_bottom($VERSION);
$session->flush or warn "Session error: ",$session->session->errstr;
exit 0;
#################################################################################
#--------------------------------- lots of subroutines --------------------------
#################################################################################
# ASYNCHRONOUS EVENTS HANDLED HERE
sub handle_asynchronous_events {
my $settings = shift;
# ASYNCHRONOUS EVENTS HANDLED HERE
# we get here on the AJAX-style asynchronous setting of labels
my $asynchronous;
if (my @ajax_labels = param('label[]')) {
my %seen;
@{$settings->{tracks}} = grep {length()>0 && !$seen{$_}++}
map {CGI::unescape($_)}
(@ajax_labels,@{$settings->{tracks}});
$asynchronous++;
}
for my $p (grep {/^div_visible_/} param()) {
my $visibility = param($p);
$p =~ s/^div_visible_//;
$settings->{section_visible}{$p} = $visibility;
$asynchronous++;
}
for my $p (grep {/^track_collapse_/} param()) {
my $collapsed = param($p);
$p =~ s/^track_collapse_//;
$settings->{track_collapsed}{$p} = $collapsed;
$asynchronous++;
}
if (param('clear_galaxy')) {
delete $settings->{GALAXY_URL};
$asynchronous++;
}
return $asynchronous;
}
sub main_display {
my ($segments,$features,$page_settings) = @_;
my ($segment,$whole_segment);
# first of all, if there are no segments, then try a keyword search and store the results
if (param() && (@$segments == 0) && (my $n = $page_settings->{name})) {
error($CONFIG->tr('NOT_FOUND',escapeHTML($n)));
}
# if there's a single segment, then print a message and store the segment into a scalar
elsif (@$segments == 1) {
$segment = $segments->[0];
$whole_segment = $CONFIG->whole_segment($segment);
# truncate the segment to fit within min and max segment boundaries
resize(\$segment,$whole_segment);
# $segment = truncated_segment($segment) if $segment->length < 4;
my $divider = $CONFIG->setting(general=>'unit_divider') || 1;
my $seg_start = $segment->start;
my $seg_end = $segment->end;
if ($divider != 1 ) {
$seg_start = $CONFIG->unit_label($seg_start);
$seg_end = $CONFIG->unit_label($seg_end);
}
print h2($CONFIG->tr('SHOWING_FROM_TO',
scalar $CONFIG->unit_label($segment->length),
$segment->seq_id,
commas($seg_start),
commas($seg_end)));
}
# force flipping
if ($segment && $segment->end < $segment->start) {
($segment) = $segment->factory->segment(-name => $segment->seq_id,
-start => $segment->end,
-stop => $segment->start,
-absolute => 1);
$page_settings->{flip} = 1;
}
# print the top of the form, with navigation bar, etc
my $msie_hack = CGI->user_agent =~ /MSIE/ && $CONFIG->setting('msie hack');
my $src = $CONFIG->source;
my $action = $src ? url(-absolute=>1)."/$src/" : url(-absolute=>1);
print galaxy_form($page_settings) if $page_settings->{GALAXY_URL} || $CONFIG->setting('galaxy');
print $msie_hack ? startform(-name => 'mainform',
-action => $action,
-method => 'GET')
: start_multipart_form(-name => 'mainform',
-action => $action,
-method => 'POST');
print navigation_table($segment,$page_settings);
print html_frag('html2',$segment,$page_settings);
# NOTE: we may exit out on the next statement if the user wants to download a previously-
# uploaded file
my $feature_files = load_external_sources($segments,$page_settings)
unless $CONFIG->section_setting('upload_tracks') eq 'off';
# if more than one segment, then list them all
if (@$segments > 1) {
multiple_choices($page_settings,$features);
# empty sections
# print toggle('Overview','');
# print toggle('Region','') if $page_settings->{region_size};
# print toggle('Details','');
}
elsif ($segment) {
adjust_region_size($segment,$page_settings);
# if a plugin passes us back a Feature, rather than a Segment, turn it into a segment
# (this shouldn't happen - hah!)
($segment) = open_database()->segment($segment->seq_id,
$segment->start,$segment->end)
unless $segment->can('features');
# display some additional info for the rubber-band select libraries
segment_info($page_settings,$segment,$whole_segment);
print overview_panel($whole_segment,$segment,$page_settings,$feature_files);
if ($CONFIG->setting('region segment') && $page_settings->{region_size}) {
my ($region_seg_start, $region_seg_end) = get_regionview_seg($page_settings,$segment->start, $segment->end,
$whole_segment->start,$whole_segment->end);
my ($region_segment) = open_database()->segment(-name=>$segment->seq_id,
-start=>$region_seg_start,
-end=>$region_seg_end,
-absolute=>1);
print region_panel($region_segment,$segment,$page_settings,$feature_files);
}
print detail_panel_with_timeout($segment,$page_settings,$feature_files);
print table({-width=>'100%'},
TR(td({-align=>'left'},
a({-href=>"?name=$page_settings->{name};h_feat=_clear_;h_region=_clear_"},
font({-size=>-2},$CONFIG->tr('Clear_highlighting')))),
td({-align=>'right'},
b(submit(-name => $CONFIG->tr('Update'))))));
} else {
# empty overview,region & detail sections
# print toggle('Overview','');
# print toggle('Region','') if $page_settings->{region_size};
# print toggle('Details');
}
print html_frag('html3',$segment,$page_settings);
print html_frag('html4',$segment,$page_settings);
print hr();
print tracks_table($page_settings,$feature_files);
print html_frag('html5',$segment,$page_settings);
print settings_table($page_settings);
print html_frag('html6',$segment,$page_settings);
print end_form();
unless ($CONFIG->section_setting('upload_tracks') eq 'off') {
print start_multipart_form(-name=>'externalform');
print external_table($page_settings,$feature_files);
print end_form();
}
# clean us up
# clean us up
foreach (values %$feature_files) {
$_ && ref($_) && eval{$_->finished};
}
}
sub hide {
my ($name,$value) = @_;
print hidden( -name => $name,
-value => $value,
-override => 1 ), "\n";
}
sub segment_info {
my ($settings,$segment,$whole_segment) = @_;
my $pad = $CONFIG->image_padding;
my $max = $CONFIG->setting('max segment') || MAX_SEGMENT;
my $width = ($settings->{width} * OVERVIEW_RATIO);
hide(image_padding => $pad);
hide(max_segment => $max);
hide(overview_start => $whole_segment->start);
hide(overview_stop => $whole_segment->end);
hide(overview_pixel_ratio => $whole_segment->length/$width);
hide(details_pixel_ratio => $segment->length/$settings->{width});
hide(detail_width => $settings->{width} + 2*$pad);
hide(overview_width => $width + 2*$pad);
if ($settings->{region_size}) {
my ($rstart, $rend) = get_regionview_seg($settings,$segment->start, $segment->end,
$whole_segment->start,$whole_segment->end);
my $rlen = abs($rend - $rstart);
my $ratio = $rlen/$width;
hide(region_start => $rstart);
hide(region_stop => $rend);
hide(region_pixel_ratio => $rlen/$width);
}
}
sub overview_panel {
my ($whole_segment,$segment,$page_settings,$feature_files) = @_;
return '' if $CONFIG->section_setting('overview') eq 'hide';
my $image = overview($whole_segment,$segment,$page_settings,$feature_files);
$image =~ s/\>/onclick="document.mainform.submit()"\>/;
return toggle($page_settings,
'Overview',
table({-border=>0,-width=>'100%'},
TR({-class=>'databody'},
td({-align=>'center'},$image)
)
)
);
}
sub region_panel {
my ($region_segment,$segment,$page_settings,$feature_files) = @_;
return '' if $CONFIG->section_setting('region') eq 'hide';
my $image = regionview($region_segment,$segment,$page_settings,$feature_files);
return toggle($page_settings,
'Region',
table({-border=>0,-width=>'100%'},
TR({-class=>'databody'},
td({-align=>'center'},$image)
)
)
);
}
sub detail_panel_with_timeout {
my @args = @_;
my $timeout = $CONFIG->setting('request timeout') || GLOBAL_TIMEOUT;
local $SIG{ALRM} = sub { die "timeout\n" };
my $data = eval {
alarm($timeout);
detail_panel(@args);
};
alarm(0);
if ($@ =~ /^timeout/) {
return p(b(font({-size=>'+2'},$CONFIG->tr('TIMEOUT'))));
} else {
warn $@ if $@ && $@ !~ /^timeout/ ;
return $data;
}
}
sub detail_panel {
my ($segment,$page_settings,$feature_files) = @_;
return '' if $CONFIG->section_setting('details') eq 'hide';
my $panels = '';
if ($segment->length <= $MAX_SEGMENT) {
$CONFIG->width($page_settings->{width});
my @tracks_to_show = grep {$page_settings->{features}{$_}{visible} && !/:(overview|region)$/ }
@{$page_settings->{tracks}};
my ($options,$limits) = get_options(\@tracks_to_show,$page_settings);
my $h_callback = make_hilite_callback($page_settings);
my $postgrid = make_postgrid_callback($page_settings);
# additional information that helps determine whether to use a panel from the cache
$page_settings->{h_feat} ||= {};
$page_settings->{h_region} ||= [];
my @cache_extra = (
sort keys %{$page_settings->{h_feat}},
sort @{$page_settings->{h_region}},
$page_settings->{show_tooltips},
);
$panels = $CONFIG->render_panels({segment => $segment,
feature_files => $feature_files,
labels => \@tracks_to_show,
options => $options,
limit => $limits,
section => '?details',
do_map => 1,
do_centering_map => 1,
lang => $CONFIG->language,
keystyle => $page_settings->{ks},
flip => $page_settings->{flip} || undef,
postgrid => $postgrid || $CONFIG->setting('postgrid') || '',
background => $CONFIG->setting('background') || '',
hilite_callback => $h_callback || undef,
settings => $page_settings,
section => '?detail',
cache_extra => \@cache_extra,
cache => $page_settings->{cache} || 0,
-add_category_labels => $CONFIG->setting('show track categories') || undef,
-grid => $page_settings->{grid} || 0,
drag_n_drop => $page_settings->{drag_and_drop}||0,
}
);
}
else {
$panels = div($CONFIG->tr('TOO_BIG',
scalar $CONFIG->unit_label($MAX_SEGMENT),
scalar $CONFIG->unit_label($DEFAULT_SEGMENT)));
}
my $error_msg = $CONFIG->error
? p({-style=>"color: red"},
"An error occurred while processing an uploaded or remote annotation file: ",
b($CONFIG->error) )
: '';
my $hints = join '',unique(hidden('ref')),unique(hidden('start')),unique(hidden('stop'));
unless ($CONFIG->drag_and_drop()) {
return div(toggle($page_settings,
'Details',
div({-id=>'panels',-class=>'track'},
$panels
)
)
)
}
my $drag_script = drag_script('panels','track');
return div(toggle($page_settings,
'Details',
div({-id=>'panels',-class=>'track'},
$panels
)
)
).$drag_script;
}
sub drag_script {
my ($container_id,$part_id) = @_;
return <<END;
<script type="text/javascript">
// <![CDATA[
Sortable.create(
"$container_id",
{
constraint: 'vertical',
tag: 'div',
only: '$part_id',
handle: 'draghandle',
onUpdate: function() {
var postData = Sortable.serialize('$container_id',{name:'label'});
new Ajax.Request(document.URL,{method:'post',postBody:postData});
}
}
);
// ]]>
</script>
END
}
###############################################################################################
sub page_settings {
my $config = shift;
my $source = param('source') || param('src') || path_info();
$source =~ s!^/+!!; # get rid of leading & trailing / from path_info()
$source =~ s!/+$!!;
my @sources = sort $config->sources;
my %sources = map {$_=>1} @sources;
if ($source) {
if ($sources{$source}) {
$config->source($source);
} else {
error($CONFIG->tr('INVALID_SOURCE',$source));
}
}
my $session = Bio::Graphics::Browser::PageSettings->new($config,param('id'));
$source ||= $session->source;
$source ||= $sources[0];
redirect_legacy_url($source); # may cause a redirect and exit!!!
my $old_source = $session->source($source);
$config->source($source);
# NOTE: bad form to set these globals here, but they are needed by adjust_settings();
$MAX_SEGMENT = $CONFIG->get_max_segment;
$DEFAULT_SEGMENT = $CONFIG->get_default_segment;
my $page_settings = get_settings($session);
adjust_settings($page_settings);
return ($page_settings,$session);
}
# read from cookie, if there is one
# if not, set from defaults
sub get_settings {
my $session = shift;
my $hash = $session->page_settings;
delete $hash->{flip}; # obnoxious for this to persist
default_settings($hash) if param('reset') or !%$hash;
$hash->{id} = $session->id;
$hash;
}
sub default_settings {
my $settings = shift;
warn "Setting default settings" if DEBUG;
%$settings = ();
@$settings{'name','ref','start','stop','flip','version'} = ('','','','','',100);
$settings->{width} = $CONFIG->setting('default width');
$settings->{source} = $CONFIG->source;
$settings->{region_size} = $CONFIG->setting('region segment');
$settings->{cache} = defined $CONFIG->cache_time ? $CONFIG->cache_time : 1;
$settings->{drag_and_drop} = $CONFIG->drag_and_drop;
$settings->{v} = $VERSION;
$settings->{show_tooltips} = 1;
$settings->{stp} = 1;
$settings->{ins} = 1;
$settings->{head} = 1;
$settings->{ks} = 'between';
$settings->{grid} = 1;
$settings->{sk} = $CONFIG->setting("default varying") ? "unsorted" : "sorted";
$settings->{config_file_version} = $CONFIG->setting('version') || 0;
set_default_tracks($settings);
}
sub set_default_tracks {
my $settings = shift;
my @labels = $CONFIG->labels;
$settings->{tracks} = \@labels;
warn "order = @labels" if DEBUG;
foreach (@labels) {
$settings->{features}{$_} = {visible=>0,options=>0,limit=>0};
}
foreach ($CONFIG->default_labels) {
$settings->{features}{$_}{visible} = 1;
}
}
# This is called to check that the list of feature types given
# in the configuration file are consistent with the features
# given in the user's cookie. If not, the settings are adjusted
# as best we can. The attempt here is to allow
# the administrator to add new feature stanzas
# without invalidating users' old settings.
sub adjust_tracks {
my $settings = shift;
my %configured_labels = map {$_=>1} $CONFIG->labels;
my %stored_labels = map {$_=>1} @{$settings->{tracks}};
my %forced_on = map {$_=>1} param('label'),shellwords($CONFIG->setting('default features'));
# tracks added to the config file recently that are not contained in
# user's stored settings.
foreach (grep {!$stored_labels{$_}} keys %configured_labels) {
$settings->{features}{$_}{visible} ||= $forced_on{$_}; # visible if requested or default
$settings->{track_collapsed}{$_} ||= 0; # not collapsed
$settings->{features}{$_}{options} ||= 0; # automatic
push @{$settings->{tracks}},$_; # at the end
}
# Remove any feature types that are not mentioned in the
# config file, excepting Uploaded and remote URL features.
# This may happen if a stanza is removed from the config file.
my %extra = map {$_=>1} grep {!/^(http|ftp|das|file|plugin):/
&& !$configured_labels{$_}} keys %{$settings->{features}};
my @extra_plugins = grep {!$PLUGIN_NAME2LABEL{$_}} grep {/^plugin:/} keys %{$settings->{features}};
# remove extra from tracks && options
if (%extra || @extra_plugins) {
delete $settings->{features}{$_} foreach (keys %extra,@extra_plugins);
}
# make sure that tracks are completely consistent with options
$settings->{tracks} = [grep {exists $settings->{features}{$_}} @{$settings->{tracks}}];
}
# auto-open any tracks that match the search term
sub auto_open {
my ($settings,$features) = @_;
my $tracks = $settings->{features};
for my $feature (@$features) {
my $desired_label = $CONFIG->feature2label($feature) or next;
if (exists $tracks->{$desired_label}) {
$tracks->{$desired_label}{visible} = 1;
$settings->{track_collapsed}{$desired_label} = 0;
$settings->{h_feat} = {};
$settings->{h_feat}{$feature->display_name} = hilite_fill() || 'yellow'
unless param('h_feat') && param('h_feat') eq '_clear_';
}
}
}
sub reset_cookies {
my @cookies;
foreach my $c (CGI::cookie()) {
push @cookies,CGI::Cookie->new(-name => $c,
-path => url(-path_info=>1,-absolute=>1),
-expires => '-1y'
);
push @cookies,CGI::Cookie->new(-name=>'CGI__Toggle',
-path => '/', # fix a bug introduced by transitional versions of software
-expires => '-1y');
}
return \@cookies;
}
sub adjust_region_size {
my ($segment,$settings) = @_;
my $region_size;
my $length = $segment ? $segment->length : abs($settings->{stop} - $settings->{start});
my $whole_segment = $CONFIG->whole_segment($segment) if $segment;
if ($CONFIG->setting('region segment') eq 'AUTO') {
$region_size = 10*$length;
}
else {
$region_size = param('region_size') if defined param('region_size');
$region_size ||= $CONFIG->setting('region segment');
$region_size ||= $settings->{region_size} || 10*$length;
}
$region_size = $whole_segment->length if $whole_segment && $region_size > $whole_segment->length;
$settings->{region_size} = $region_size;
}
# This is called to change the values of the settings
sub adjust_settings {
my $settings = shift;
# this is called to bring the settings hash up to the correct gbrowse version
return if upgrade_settings($settings);
if (param('width') || param('label')) { # just looking to see if the settings form was submitted
my @selected = split_labels (param('label'));
$settings->{features}{$_}{visible} = 0 foreach keys %{$settings->{features}};
$settings->{features}{$_}{visible} = 1 foreach @selected;
$settings->{flip} = param('flip');
$settings->{grid} = param('grid');
unless (defined $CONFIG->setting('cache time') && $CONFIG->setting('cache time') == 0) {
$settings->{cache} = param('cache');
$settings->{cache} = !param('nocache') if defined param('nocache');
}
if ($CONFIG->setting('drag and drop')) {
$settings->{drag_and_drop} = param('drag_and_drop');
} else {
$settings->{drag_and_drop} = 0;
}
$settings->{show_tooltips} = param('show_tooltips');
}
if (my @selected = split_labels(param('enable'))) {
$settings->{features}{$_}{visible} = 1 foreach @selected;
}
if (my @selected = split_labels(param('disable'))) {
$settings->{features}{$_}{visible} = 0 foreach @selected;
}
$settings->{width} = param('width') if param('width');
my $divider = $CONFIG->setting('unit_divider') || 1;
# Update coordinates.
local $^W = 0; # kill uninitialized variable warning
$settings->{ref} = param('ref');
$settings->{start} = param('start') if defined param('start') && param('start') =~ /^[\d-]+/;
$settings->{stop} = param('stop') if defined param('stop') && param('stop') =~ /^[\d-]+/;
$settings->{stop} = param('end') if defined param('end') && param('end') =~ /^[\d-]+/;
$settings->{version} ||= param('version') || '';
if ( (request_method() eq 'GET' && param('ref'))
||
(param('span') && $settings->{stop}-$settings->{start}+1 != param('span'))
||
grep {/left|right|zoom|nav|region\.[xy]|overview\.[xy]/} param()
)
{
zoomnav($settings);
$settings->{name} = "$settings->{ref}:$settings->{start}..$settings->{stop}";
param(name => $settings->{name});
}
foreach (qw(name source plugin stp ins head
ks sk version)) {
$settings->{$_} = param($_) if defined param($_);
}
$settings->{name} =~ s/^\s+//; # strip leading
$settings->{name} =~ s/\s+$//; # and trailing whitespace
if (my @features = shellwords(param('h_feat'))) {
$settings->{h_feat} = {};
for my $hilight (@features) {
last if $hilight eq '_clear_';
my ($featname,$color) = split '@',$hilight;
$settings->{h_feat}{$featname} = $color || hilite_fill() || 'yellow';
}
}
if (my @regions = shellwords(param('h_region'))) {
$settings->{h_region} = [];
foreach (@regions) {
last if $_ eq '_clear_';
$_ = "$settings->{ref}:$_" unless /^[^:]+:-?\d/; # add reference if not there