tools/winapi/output.pm

   1 #
   2 # Copyright 1999, 2000, 2001 Patrik Stridvall
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2.1 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  17 #
  18
  19 package output;
  20
  21 use strict;
  22
  23 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  24 require Exporter;
  25
  26 @ISA = qw(Exporter);
  27 @EXPORT = qw();
  28 @EXPORT_OK = qw($output);
  29
  30 use vars qw($output);
  31
  32 $output = '_output'->new;
  33
  34 package _output;
  35
  36 use strict;
  37
  38 my $stdout_isatty = -t STDOUT;
  39 my $stderr_isatty = -t STDERR;
  40
  41 sub new($) {
  42     my $proto = shift;
  43     my $class = ref($proto) || $proto;
  44     my $self  = {};
  45     bless ($self, $class);
  46
  47     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  48     my $progress = \${$self->{PROGRESS}};
  49     my $last_progress = \${$self->{LAST_PROGRESS}};
  50     my $last_time = \${$self->{LAST_TIME}};
  51     my $progress_count = \${$self->{PROGRESS_COUNT}};
  52     my $prefix = \${$self->{PREFIX}};
  53     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
  54
  55     $$progress_enabled = 1;
  56     $$progress = "";
  57     $$last_progress = "";
  58     $$last_time = 0;
  59     $$progress_count = 0;
  60     $$prefix = undef;
  61     $$prefix_callback = undef;
  62
  63     return $self;
  64 }
  65
  66 sub DESTROY {
  67     my $self = shift;
  68
  69     $self->hide_progress;
  70 }
  71
  72 sub enable_progress($) {
  73     my $self = shift;
  74     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  75
  76     $$progress_enabled = 1;
  77 }
  78
  79 sub disable_progress($) {
  80     my $self = shift;
  81     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  82
  83     $$progress_enabled = 0;
  84 }
  85
  86 sub show_progress($) {
  87     my $self = shift;
  88     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  89     my $progress = ${$self->{PROGRESS}};
  90     my $last_progress = \${$self->{LAST_PROGRESS}};
  91     my $progress_count = \${$self->{PROGRESS_COUNT}};
  92
  93     $$progress_count++;
  94
  95     if($$progress_enabled) {
  96         if($$progress_count > 0 && $$progress && $stderr_isatty) {
  97             # If progress has more than $columns characters the xterm will
  98             # scroll to the next line and our ^H characters will fail to
  99             # erase it.
 100             my $columns=$ENV{COLUMNS} || 80;
 101             $progress = substr $progress,0,($columns-1);
 102             print STDERR $progress;
 103             $$last_progress = $progress;
 104         }
 105     }
 106 }
 107
 108 sub hide_progress($)  {
 109     my $self = shift;
 110     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
 111     my $progress = \${$self->{PROGRESS}};
 112     my $last_progress = \${$self->{LAST_PROGRESS}};
 113     my $progress_count = \${$self->{PROGRESS_COUNT}};
 114
 115     $$progress_count--;
 116
 117     if($$progress_enabled) {
 118         if($$last_progress && $stderr_isatty) {
 119             my $message="\b \b" x length($$last_progress);
 120             print STDERR $message;
 121             undef $$last_progress;
 122         }
 123     }
 124 }
 125
 126 sub update_progress($) {
 127     my $self = shift;
 128     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
 129     my $progress = ${$self->{PROGRESS}};
 130     my $last_progress = \${$self->{LAST_PROGRESS}};
 131
 132     if($$progress_enabled) {
 133         # If progress has more than $columns characters the xterm will
 134         # scroll to the next line and our ^H characters will fail to
 135         # erase it.
 136         my $columns=$ENV{COLUMNS} || 80;
 137         $progress = substr $progress,0,($columns-1);
 138
 139         my $prefix = "";
 140         my $suffix = "";
 141         if($$last_progress) {
 142             $prefix = "\b" x length($$last_progress);
 143
 144             my $diff = length($$last_progress)-length($progress);
 145             if($diff > 0) {
 146                 $suffix = (" " x $diff) . ("\b" x $diff);
 147             }
 148         }
 149         print STDERR $prefix, $progress, $suffix;
 150         $$last_progress = $progress;
 151     }
 152 }
 153
 154 sub progress($$) {
 155     my $self = shift;
 156     my $progress = \${$self->{PROGRESS}};
 157     my $last_time = \${$self->{LAST_TIME}};
 158
 159     my $new_progress = shift;
 160     if(defined($new_progress)) {
 161         if(!defined($$progress) || $new_progress ne $$progress) {
 162             $$progress = $new_progress;
 163
 164             $self->update_progress;
 165             $$last_time = 0;
 166         }
 167     } else {
 168         return $$progress;
 169     }
 170 }
 171
 172 sub lazy_progress($$) {
 173     my $self = shift;
 174     my $progress = \${$self->{PROGRESS}};
 175     my $last_time = \${$self->{LAST_TIME}};
 176
 177     $$progress = shift;
 178
 179     my $time = time();
 180     if($time - $$last_time > 0) {
 181         $self->update_progress;
 182         $$last_time = $time;
 183     }
 184 }
 185
 186 sub prefix($$) {
 187     my $self = shift;
 188     my $prefix = \${$self->{PREFIX}};
 189     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
 190
 191     my $new_prefix = shift;
 192     if(defined($new_prefix)) {
 193         if(!defined($$prefix) || $new_prefix ne $$prefix) {
 194             $$prefix = $new_prefix;
 195             $$prefix_callback = undef;
 196         }
 197     } else {
 198         return $$prefix;
 199     }
 200 }
 201
 202 sub prefix_callback($) {
 203     my $self = shift;
 204
 205     my $prefix = \${$self->{PREFIX}};
 206     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
 207
 208     $$prefix = undef;
 209     $$prefix_callback = shift;
 210 }
 211
 212 sub write($$) {
 213     my $self = shift;
 214
 215     my $message = shift;
 216
 217     my $prefix = \${$self->{PREFIX}};
 218     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
 219
 220     $self->hide_progress if $stdout_isatty;
 221     if(defined($$prefix)) {
 222         print $$prefix . $message;
 223     } elsif(defined($$prefix_callback)) {
 224         print &{$$prefix_callback}() . $message;
 225     } else {
 226         print $message;
 227     }
 228     $self->show_progress if $stdout_isatty;
 229 }
 230
 231 1;