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 use warnings 'all';
  23
  24 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  25 require Exporter;
  26
  27 @ISA = qw(Exporter);
  28 @EXPORT = qw();
  29 @EXPORT_OK = qw($output);
  30
  31 use vars qw($output);
  32
  33 $output = '_output'->new;
  34
  35 package _output;
  36
  37 use strict;
  38 use warnings 'all';
  39
  40 my $stdout_isatty = -t STDOUT;
  41 my $stderr_isatty = -t STDERR;
  42
  43 sub new($) {
  44     my $proto = shift;
  45     my $class = ref($proto) || $proto;
  46     my $self  = {};
  47     bless ($self, $class);
  48
  49     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  50     my $progress = \${$self->{PROGRESS}};
  51     my $last_progress = \${$self->{LAST_PROGRESS}};
  52     my $last_time = \${$self->{LAST_TIME}};
  53     my $progress_count = \${$self->{PROGRESS_COUNT}};
  54     my $prefix = \${$self->{PREFIX}};
  55     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
  56
  57     $$progress_enabled = 1;
  58     $$progress = "";
  59     $$last_progress = "";
  60     $$last_time = 0;
  61     $$progress_count = 0;
  62     $$prefix = undef;
  63     $$prefix_callback = undef;
  64
  65     return $self;
  66 }
  67
  68 sub DESTROY {
  69     my $self = shift;
  70
  71     $self->hide_progress;
  72 }
  73
  74 sub enable_progress($) {
  75     my $self = shift;
  76     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  77
  78     $$progress_enabled = 1;
  79 }
  80
  81 sub disable_progress($) {
  82     my $self = shift;
  83     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  84
  85     $$progress_enabled = 0;
  86 }
  87
  88 sub show_progress($) {
  89     my $self = shift;
  90     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
  91     my $progress = ${$self->{PROGRESS}};
  92     my $last_progress = \${$self->{LAST_PROGRESS}};
  93     my $progress_count = \${$self->{PROGRESS_COUNT}};
  94
  95     $$progress_count++;
  96
  97     if($$progress_enabled) {
  98         if($$progress_count > 0 && $$progress && $stderr_isatty) {
  99             # If progress has more than $columns characters the xterm will
 100             # scroll to the next line and our ^H characters will fail to
 101             # erase it.
 102             my $columns=$ENV{COLUMNS} || 80;
 103             $progress = substr $progress,0,($columns-1);
 104             print STDERR $progress;
 105             $$last_progress = $progress;
 106         }
 107     }
 108 }
 109
 110 sub hide_progress($)  {
 111     my $self = shift;
 112     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
 113     my $progress = \${$self->{PROGRESS}};
 114     my $last_progress = \${$self->{LAST_PROGRESS}};
 115     my $progress_count = \${$self->{PROGRESS_COUNT}};
 116
 117     $$progress_count--;
 118
 119     if($$progress_enabled) {
 120         if($$last_progress && $stderr_isatty) {
 121             my $message="\b \b" x length($$last_progress);
 122             print STDERR $message;
 123             undef $$last_progress;
 124         }
 125     }
 126 }
 127
 128 sub update_progress($) {
 129     my $self = shift;
 130     my $progress_enabled = \${$self->{PROGRESS_ENABLED}};
 131     my $progress = ${$self->{PROGRESS}};
 132     my $last_progress = \${$self->{LAST_PROGRESS}};
 133
 134     if($$progress_enabled) {
 135         # If progress has more than $columns characters the xterm will
 136         # scroll to the next line and our ^H characters will fail to
 137         # erase it.
 138         my $columns=$ENV{COLUMNS} || 80;
 139         $progress = substr $progress,0,($columns-1);
 140
 141         my $prefix = "";
 142         my $suffix = "";
 143         if($$last_progress) {
 144             $prefix = "\b" x length($$last_progress);
 145
 146             my $diff = length($$last_progress)-length($progress);
 147             if($diff > 0) {
 148                 $suffix = (" " x $diff) . ("\b" x $diff);
 149             }
 150         }
 151         print STDERR $prefix, $progress, $suffix;
 152         $$last_progress = $progress;
 153     }
 154 }
 155
 156 sub progress($$) {
 157     my $self = shift;
 158     my $progress = \${$self->{PROGRESS}};
 159     my $last_time = \${$self->{LAST_TIME}};
 160
 161     my $new_progress = shift;
 162     if(defined($new_progress)) {
 163         if(!defined($$progress) || $new_progress ne $$progress) {
 164             $$progress = $new_progress;
 165
 166             $self->update_progress;
 167             $$last_time = 0;
 168         }
 169     } else {
 170         return $$progress;
 171     }
 172 }
 173
 174 sub lazy_progress($$) {
 175     my $self = shift;
 176     my $progress = \${$self->{PROGRESS}};
 177     my $last_time = \${$self->{LAST_TIME}};
 178
 179     $$progress = shift;
 180
 181     my $time = time();
 182     if($time - $$last_time > 0) {
 183         $self->update_progress;
 184         $$last_time = $time;
 185     }
 186 }
 187
 188 sub prefix($$) {
 189     my $self = shift;
 190     my $prefix = \${$self->{PREFIX}};
 191     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
 192
 193     my $new_prefix = shift;
 194     if(defined($new_prefix)) {
 195         if(!defined($$prefix) || $new_prefix ne $$prefix) {
 196             $$prefix = $new_prefix;
 197             $$prefix_callback = undef;
 198         }
 199     } else {
 200         return $$prefix;
 201     }
 202 }
 203
 204 sub prefix_callback($) {
 205     my $self = shift;
 206
 207     my $prefix = \${$self->{PREFIX}};
 208     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
 209
 210     $$prefix = undef;
 211     $$prefix_callback = shift;
 212 }
 213
 214 sub write($$) {
 215     my $self = shift;
 216
 217     my $message = shift;
 218
 219     my $prefix = \${$self->{PREFIX}};
 220     my $prefix_callback = \${$self->{PREFIX_CALLBACK}};
 221
 222     $self->hide_progress if $stdout_isatty;
 223     if(defined($$prefix)) {
 224         print $$prefix . $message;
 225     } elsif(defined($$prefix_callback)) {
 226         print &{$$prefix_callback}() . $message;
 227     } else {
 228         print $message;
 229     }
 230     $self->show_progress if $stdout_isatty;
 231 }
 232
 233 1;