view release on metacpan or  search on metacpan

WebOut.pm  view on Meta::CPAN

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
    @Headers = ();
    $$rRootBuf = '';
  }
  # Åñëè íè÷åãî íå èçìåíèëîñü, âûõîäèì
  return if tied(*STDOUT) && ref tied(*STDOUT) eq __PACKAGE__."::Tie";
  tie(*STDOUT, __PACKAGE__."::Tie", \*STDOUT, tied(*STDOUT));
}
 
 
# Ïðîâåðÿåò, èñïîëüçóåòñÿ ëè áèáëèîòåêà Web-ñêðèïòîì èëè îáû÷íûì
sub IsWebMode() { 
  return $ENV{SCRIPT_NAME}? 1 : 0 
}
 
 
# Ïîñëàíû ëè çàãîëîâêè?
sub HeadersSent { 
  return $HeadersSent;
}

WebOut.pm  view on Meta::CPAN

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
 
 
# Ïåðåõâàò âûõîäíîãî ïîòîêà. Èñïîëüçîâàíèå:
# $grabbed = grab { 
#     print 'Hello!' 
# } catch {
#     die "An error occurred while grabbing the output: $@";
# };
# èëè òî æå, íî áåç catch: 
# $grabbed = grab { print 'Hello!' };
sub grab(&@)
{ my ($func, $catch)=@_;
  my $Buf = CGI::WebOut->new; 
  $@ = undef; eval { &$func() };
  if ($@ && $catch) { chomp($@); local $_ = $@; &$catch; }
  return $Buf->buf;
}
 
 
# static Header($header)
# Óñòàíàâëèâàåò çàãîëîâîê îòâåòà.
sub Header($)
{ my ($head)=@_;
  if ($HeadersSent) {
    eval { require Carp } 
      and Carp::carp("Oops... Header('$head') called after content had been sent to browser!\n"); 
    return undef; 
  }
  push(@Headers, $head);
  return 1;
}
 
 
# Ñáðàñûâàåò ñîäåðæèìîå ãëàâíîãî áóôåðà â áðàóçåð.
sub Flush() { 
  # Îòêëþ÷àåì âíóòðåííþþ áóôåðèçàöèþ Perl-à
  local $| = 1; 
  # Åñëè çàãîëîâêè åùå íå îòîñëàíû, îòîñëàòü èõ
  if (!$HeadersSent && IsWebMode()) {
    my $ContType="text/html";
    unshift(@Headers,"X-Powered-By: CGI::WebOut v$VERSION (http://www.dklab.ru/chicken/4.html), (C) by Dmitry Koterov");
    # Èùåì Content-type, ÷òîáû ïîòîì îòïðàâèòü åãî â êîíöå
    for (my $i=0; $i<@Headers; $i++) {
      if ($Headers[$i]=~/^content-type: *(.*)$/i) {
        $ContType = $1; splice(@Headers, $i, 1); $i--;

WebOut.pm  view on Meta::CPAN

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
  local @Warns = @Errors>@SvErrors? @Errors[@SvErrors..$#Errors] : ();
  # Âîññòàíàâëèâàåì ñîîáùåíèÿ îá îøèáêàõ
  @Errors = @SvErrors;
  # Çàïóñêàåì îáðàáîò÷èêè â ïîðÿäêå èõ ïîÿâëåíèÿ
  map { &$_() } @Hand;
  # Âîçâðàùàåì çíà÷åíèå, êîòîðîå âåðíóë try-áëîê
  return wantarray? @Result: $Result[0];
}
 
# Âîçâðàùàåò ôóíêöèþ-çàìûêàíèå, êîòîðàÿ âûçûâàåò òåëî catch-áëîêà.
sub catch(&;@) 
{ my ($body, @Hand)=@_;
  return (sub { if($@) { chomp($@); local $_=$@; &$body($_) } }, @Hand);
}
 
# Âîçâðàùàåò ôóíêöèþ-çàìûêàíèå, êîòîðàÿ âûçûâàåò òåëî warnings-áëîêà.
sub warnings(&;@) 
{ my ($body,@Hand)=@_;
  return (sub { &$body(@Warns) }, @Hand);
}
 
# Âûáðàñûâàåò èñêëþ÷åíèå.
sub throw($) { 
  die(ref($_[0])? $_[0] : "$_[0]\n") 
}
 
 
# bool SetAutoflush([bool $mode])
# Óñòàíàâëèâàåò ðåæèì ñáðîñà áóôåðà echo: åñëè $mode=1, òî ðàçðåøàåò åãî àâòîñáðîñ ïîñëå
# êàæäîãî âûâîäà print èëè echo, èíà÷å - çàïðåùàåò (ñáðîñ äîëæåí ïðîèçâîäèòüñÿ ïî Flush()).
# Âîçâðàùàåò ïðåäûäóùèé óñòàíîâëåííûé ðåæèì àâòîñáðîñà.
sub SetAutoflush(;$)
{ my ($mode)=@_;
  my $old = $UseAutoflush;
  if (defined $mode) { $UseAutoflush = $mode; }
  return $old;
}
 
# bool NoAutoflush()
# Çàïðåùàåò ñáðàñûâàòü áóôåð ïîñëå êàæäîãî echo.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ àâòîñáðîñà.
sub NoAutoflush() {
  return SetAutoflush(0);
}
 
 
# bool UseAutoflush()
# Ðàçðàøàåò ñáðàñûâàòü áóôåð ïîñëå êàæäîãî echo.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ àâòîñáðîñà.
sub UseAutoflush() {
  return SetAutoflush(1);
}
 
 
# Ïåðåíàïðàâëÿåò íà äðóãîé URL (ìîæåò áûòü âíóòðåííèì ðåäèðåêòîì)
sub Redirect($)
{ my ($url) = @_;
  $Redirected = Header("Location: $url");
  exit;
}
 
 
# Ïåðåíàïðàâëÿåò ÁÐÀÓÇÅÐ íà äðóãîé URL
sub ExternRedirect($)
{ my ($url) = @_;
  if ($url !~ /^\w+:/) {
    # Îòíîñèòåëüíûé àäðåñ.
    if ($url !~ m{^/}) {
      my $sn = $ENV{SCRIPT_NAME};
      $sn =~ s{/+[^/]*$}{}sg;
      $url = "$sn/$url";
    }
    # Äîáàâèòü èìÿ õîñòà.
    $url = "http://$ENV{SERVER_NAME}$url";
  }
  $Redirected = Header("Location: $url");
  exit;
}
 
 
# Çàïðåùàåò êýøèðîâàíèå äîêóìåíòà áðàóçåðîì
sub NoCache()
{ return 1 if $NoCached++;
  Header("Expires: Mon, 26 Jul 1997 05:00:00 GMT") or return undef;
  Header("Last-Modified: ".gmtime(time)." GMT") or return undef;
  Header("Cache-Control: no-cache, must-revalidate") or return undef;
  Header("Pragma: no-cache") or return undef;
  return 1;
}
 
 
# int ErrorReporting([int $level])
# Óñòàíàâëèâàåò ðåæèì âûâîäà îøèáîê:
# 0 - îøèáêè íå âûâîäÿòñÿ
# 1 - îøèáêè âûâîäÿòñÿ â áðàóçåð
# 2 - îøèáêè âûâîäÿòñÿ â áðàóçåð â âèäå êîììåíòàðèåâ
# Åñëè ïàðàìåòð íå çàäàí, ðåæèì íå ìåíÿåòñÿ.
# Âîçâðàùàåò ïðåäûäóùèé ñòàòóñ âûâîäà.
sub ErrorReporting(;$)
{ my ($lev)=@_;
  my $old = $ErrorReporting;
  $ErrorReporting = $lev if defined $lev;
  return $old;
}
 
 
# Äîáàâëÿåò ñîîáùåíèå îá îøèáêå ê ìàññèâó îøèáîê.
sub Warning($)
{ my ($msg)=@_;
  push(@Errors, $msg);
}
 
 
# Ïå÷àòàåò âñå íàêîïèâøèåñÿ ñîîáùåíèÿ îá îøèáêàõ.
# Ýòà ôóíêöèÿ âûçûâàåòñÿ â ìîìåíò, êîãäà STDOUT íàõîäèòñÿ â "ïîäâåøåííîì" ñîñòîÿíèè, 
# ïîýòîìó èñïîëüçîâàíèå print ÇÀÏÐÅÙÅÍÎ!!!
sub __PrintAllErrors()
{ local $^W = undef;
  # http://forum.dklab.ru/perl/symbiosis/Fastcgi+WeboutUtechkaPamyati.html
  if(!@Errors || !$ErrorReporting){
    @Errors=(); 
          return ; 
  }
  if (IsWebMode) {
    if ($ErrorReporting == ER_Err2Browser) {
      # ìàëî ëè, êàêèå òàì áûëè òàáëèöû...
      echo "</script>","</xmp>","</pre>","</table>"x6,"</tt>"x2,"</i>"x2,"</b>"x2,"</div>"x10,"\n";