home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Web.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  9.3 KB  |  439 lines
  1. package Tk::UserAgent;
  2. require Tk;
  3. require Tk::LabEntry;
  4. #use LWP::IO();
  5. #use Tk::HTML::IO();
  6. #use LWP::TkIO();
  7. use LWP();
  8. @ISA = qw(LWP::UserAgent);
  9. use strict;
  10. use Tk::Pretty;
  11.  
  12. #LWP::Debug::level('+');
  13.  
  14. sub Widget
  15. {
  16.  shift->_elem('Tk::Widget',  @_)
  17. }
  18.  
  19. sub DESTROY {} 
  20.  
  21. sub get_basic_credentials
  22. {
  23.  # print 'get_basic_credentials(',join(',',@_),")\n";
  24.  my ($ua,$realm,$uri) = @_;
  25.  my $netloc = $uri->netloc;
  26.  my ($user,$passwd) = $ua->SUPER::get_basic_credentials($realm,$uri);
  27.  unless (defined $user and defined $passwd) 
  28.   {
  29.    my $w  = $ua->Widget;
  30.    my $mw = (defined $w) ? $w->Toplevel(-popover => $w) : MainWindow->new;
  31.    $mw->withdraw;
  32.    $user  = $uri->user;
  33.    $user  = $ENV{'USER'} unless (defined $user);
  34.    $passwd = $uri->password;
  35.    $passwd = "" unless (defined $passwd);
  36.    $mw->title($uri);
  37.    $mw->Label(-text => "Credentials for\n$realm\n$netloc")->pack; 
  38.    my $e = $mw->LabEntry(-label => 'Userid :',-labelPack => [-side => 'left'], -textvariable => \$user)->pack;
  39.    $e = $mw->LabEntry(-label => 'Passwd :', -labelPack => [-side => 'left'], -show => '*', -textvariable => \$passwd)->pack;
  40.    $e->bind('<Return>',[$mw,'destroy']);
  41.    $mw->Button(-text => 'Ok',     -command => ['destroy',$mw])->pack(-side => 'left');
  42.    $mw->Button(-text => 'Cancel', -command => sub { $user = $passwd = undef; $mw->destroy } )->pack(-side => 'right');
  43.    $e->Subwidget('entry')->focus;
  44.    $mw->update;    
  45.    $mw->raise;     
  46.    $mw->Popup(-overanchor => 'n', -popanchor => 'n');
  47.    eval {local $SIG{__DIE__}; $mw->grab } ;
  48.    $mw->waitWindow;
  49.    $ua->credentials($netloc,$realm,$user,$passwd);
  50.   }
  51.  return ($user,$passwd);
  52. }
  53.  
  54. package Tk::Web;
  55.  
  56. require Tk::HTML;
  57.  
  58. use Carp;
  59. use Tk::Pretty;
  60. use strict qw(vars subs);
  61. use AutoLoader;
  62.  
  63. @Tk::Web::ISA = qw(Tk::HTML);
  64. Construct Tk::Widget 'Web';
  65.  
  66. my %Loading = ();
  67. my %Image   = ();
  68.  
  69. my %iHandler = ( gif => 'Photo', 'x-xbitmap' => 'Bitmap');
  70.  
  71. $iHandler{jpeg} = 'Photo' if (Tk->findINC('JPEG.pm'));
  72.  
  73. my $filename = "image0000";
  74.  
  75. sub LoadImage
  76. {
  77.  my ($w,$url) = @_;
  78.  my $name = $url->as_string;
  79.  my $file = '.'.++$filename;
  80.  print "Loading $name to $file\n";    
  81.  my $request  = new HTTP::Request('GET', $url);
  82.  my $response = $w->UserAgent->request($request, $file);
  83.  my $image = undef;                        
  84.  my $format;
  85.  if ($response->is_success)                 
  86.   {                                        
  87.    my $type = $response->header('Content-type');
  88.    my @try  = qw(Pixmap Bitmap Photo);
  89.    if (defined $type)
  90.     {
  91.      if ($type =~ m#image/(\w+)# && exists($iHandler{$1}))
  92.       {
  93.        $format = $1;
  94.        @try = ($iHandler{$format});
  95.       }
  96.      else
  97.       {
  98.        print "$name:$type\n";
  99.       }
  100.     }
  101.    foreach $type (@try)
  102.     {
  103.      my @args = (-file => $file);
  104.      eval "require Tk::$type;";
  105.      if ($type eq 'Photo')
  106.       {
  107.        eval "require Tk::JPEG;" if ($format eq 'jpeg');
  108.        unshift(@args,'-format' => $format);
  109.       }
  110.      eval {local $SIG{__DIE__}; $image = $w->$type(@args)};
  111.      last unless ($@);
  112.     }
  113.    warn "$@" if ($@);
  114.    unlink($file);                          
  115.   }                                        
  116.  else
  117.   {
  118.    print "$name:",$response->as_string;
  119.   }
  120.  $Image{$name} = $image;
  121.  my $l;
  122.  while ($l = shift(@{$Loading{$name}}))
  123.   {
  124.    $l->configure(-image => $image) if ($l->IsWidget);
  125.   }
  126.  delete $Loading{$name};
  127.  # $w->updateWidgets;
  128. }
  129.  
  130. sub FindImage
  131. {
  132.  my ($w,$src,$l) = @_;
  133.  my $base = $w->url;
  134.  my $url  = URI::URL->new($src,$base)->abs;
  135.  my $name = $url->as_string;
  136.  if (defined $Image{$name})
  137.   {
  138.    $l->configure(-image => $Image{$name});
  139.   }
  140.  elsif (exists $Image{$name})
  141.   {
  142.    # failed in the past 
  143.   }
  144.  else
  145.   {
  146.    unless (exists $Loading{$name})
  147.     {
  148.      $Loading{$name} = [];
  149.      # $w->updateWidgets;
  150.      $w->DoWhenIdle([$w,'LoadImage',$url]); 
  151.     }
  152.    push(@{$Loading{$name}},$l); 
  153.   }
  154. }
  155.  
  156. sub UserAgent
  157. {
  158.  my ($w,$ua) = @_;
  159.  if (@_ > 1)
  160.   {
  161.    $w->{'UserAgent'} = $ua;
  162.   }
  163.  return $w->{'UserAgent'};
  164. }
  165.  
  166. sub InitObject
  167. {
  168.  my ($w,$args) = @_;
  169.  $w->SUPER::InitObject($args);
  170.  my $ua = $w->UserAgent(Tk::UserAgent->new);
  171.  $ua->Widget($w);
  172.  $ua->env_proxy;
  173.  $w->{'BACK'}    = [];
  174.  $w->{'FORWARD'} = [];
  175.  $w->ConfigSpecs('-url' => ['METHOD','url','Url',undef],
  176.                  '-urlcommand' => ['CALLBACK',undef,undef,undef]
  177.                 );
  178. }
  179.                            
  180. sub SetBindtags
  181. {
  182.  my ($w) = @_;
  183.  $w->bindtags([$w,$w->toplevel,ref $w,'all']);
  184. }
  185.  
  186. sub context
  187. {
  188.  my $w = shift;
  189.  if (@_)
  190.   {
  191.    croak("Bad context " . join(',',@_)) unless (@_ == 1 && ref $_[0] eq 'ARRAY');
  192.    my ($url,$base,$html,$top) = @{$_[0]};
  193.    $w->{-url}   = $url;
  194.    $w->{'base'} = $base;
  195.    $w->html($html);
  196.    $w->yview(moveto => $top);
  197.    $w->Callback(-urlcommand => $url->as_string);
  198.   }
  199.  return [$w->url,$w->base,$w->html,$w->yview];
  200. }
  201.  
  202. sub HREF
  203. {
  204.  my ($w,$what,$method,$content) = @_;
  205.  my $base = $w->url;
  206.  push(@{$w->{BACK}},$w->context);
  207.  my $url = URI::URL->new($what,$base);
  208.  $w->url($url,$method,$content);
  209. }
  210.  
  211. my %cache = ();
  212.  
  213. sub getHTML
  214. {
  215.  my ($w,$url,$method,$content) = @_;
  216.  $method = 'GET' unless (defined $method);
  217.  if ($method eq 'GET')
  218.   {
  219.    my $str = $url->as_string;
  220.    return $cache{$str} if (exists $cache{$str});
  221.   }
  222.  print "Requesting ",$url->as_string,"\n";
  223.  my ($request, $head);
  224.  if (defined $w->{'-header'}) 
  225.   {
  226.    $head = new HTTP::Headers(%{$w->{'-header'}});
  227.   } 
  228.  else 
  229.   {
  230.    $head = new HTTP::Headers;
  231.   }
  232.  if (defined $content) 
  233.   {
  234.    $head->header('Content-type' => 'application/x-www-form-urlencoded');
  235.    $request  = new HTTP::Request($method, $url, $head, $content);
  236.   } 
  237.  else  
  238.   {
  239.    $request  = new HTTP::Request($method, $url, $head);
  240.   }
  241.  my $response = $w->UserAgent->request($request, undef, undef);
  242.  my $html; 
  243.  if ($response->is_success)
  244.   {
  245.    return undef if $response->code == &HTTP::Status::RC_NO_CONTENT;
  246.    my $type = $response->header('Content-type');
  247.    $html = $response->content;
  248.    $html = "<H1> Empty! </H1>" unless (defined $html);
  249.    if (!defined $type || $type !~ /\bhtml\b/i)
  250.     {
  251.      print $url->as_string," is ",$type,"\n";
  252.      if ($type =~ m#(audio|application)/.*#i)
  253.       {
  254.        $html = "<H1> $type </H1>";
  255.       }
  256.      elsif ($type =~ m#image/.*#i)
  257.       {
  258.        $html = '<H1><IMG SRC="'.$url->as_string."\"> $type </H1>";
  259.       }
  260.      else
  261.       {
  262.        if ($html =~ /^%!PS/)
  263.         {
  264.          $html = "<H1> PostScript! </H1>";
  265.         }
  266.        if ($html !~ m#^\s*</?(!|\w+)#)
  267.         {
  268.          $html =~ s/([^\w\s])/'&#'.ord($1).';'/eg;
  269.          $html = "<PRE>$html</PRE>" 
  270.         }
  271.       }
  272.     }
  273.    if ($method eq 'GET')
  274.     {
  275.      $html = $w->parse($html);       
  276.      $cache{$url->as_string} = $html 
  277.     }
  278.   }
  279.  else
  280.   {
  281.    $html = $response->error_as_HTML;
  282.   }
  283.  return $html;
  284. }
  285.  
  286. sub base 
  287. {
  288.  my ($w,$text) = @_;
  289.  my $var = \$w->{'base'};
  290.  $$var   = URI::URL->newlocal unless (defined $$var);
  291.  if (@_ > 1)
  292.   {
  293.    $$var = URI::URL->new($text,$w->base);
  294.   }
  295.  return $$var;
  296. }
  297.  
  298. sub url
  299. {
  300.  my ($w,$url,$method,$content) = @_;
  301.  my $var = \$w->{'-url'};
  302.  if (@_ > 1)
  303.   {
  304.    $w->Busy;
  305.    unless (ref $url)
  306.     {
  307.      $url = URI::URL->new($url,$w->base);
  308.     }
  309.    $url = $url->abs;
  310.    my $frag = $url->frag;
  311.    $url->frag(undef) if (defined $frag);
  312.    my $html = $w->getHTML($url,$method,$content);
  313.    if (defined $html)
  314.     {
  315.      $$var = $url;
  316.      my @args = ();
  317.      if (defined $frag)
  318.       {
  319.        $url->frag($frag);
  320.        push(@args,$frag);
  321.       }
  322.      $w->Callback(-urlcommand => $url->as_string);
  323.      $w->html($html,@args); 
  324.     }
  325.    $w->Unbusy;
  326.   }
  327.  return $$var;
  328. }
  329.  
  330. 1;
  331.  
  332. __END__
  333.  
  334. sub TextPopup
  335. {
  336.  my ($w,$kind,$text) = @_;
  337.  my $t   = $w->MainWindow->Toplevel;
  338.  my $url = $w->url;
  339.  $t->title("$kind : ".$url->as_string);
  340.  my $tx = $t->Scrolled('Text',-wrap => 'none')->pack(-expand => 1, -fill => 'both');
  341.  $tx->insert('end',$text);
  342. }
  343.  
  344. sub ShowSource
  345. {
  346.  my ($w) = @_;
  347.  $w->TextPopup(Source => $w->html->{'_source_'});
  348. }
  349.  
  350. sub ShowHTML
  351. {
  352.  my ($w) = @_;
  353.  $w->TextPopup(HTML => $w->html->as_HTML);
  354. }
  355.  
  356.  
  357.  
  358. sub Open
  359. {
  360.  my ($w) = @_;
  361.  unless (exists $w->{'Open'})
  362.   {
  363.    my $t = $w->toplevel;
  364.    my $o = $w->toplevel->Toplevel(-popover => $w, -popanchor => 'n', -overanchor => 'n');
  365.    $o->withdraw;
  366.    $o->transient($t);
  367.    $o->protocol(WM_DELETE_WINDOW => [withdraw => $o]);
  368.    $w->{'Open'} = $o;
  369.    $o->{'url'}  = $w->url;
  370.    my $e = $o->LabEntry(-label => 'Location :',-labelPack => [ -side => 'left'],
  371.                 -textvariable => \$o->{'url'}, -width => length($o->{'url'}))->pack(-fill => 'x');
  372.    my $b = $o->Button(-text => 'Open', 
  373.                       -command =>  sub {  $o->withdraw ; $w->HREF('GET',$o->{'url'}) } 
  374.                      )->pack(-side => 'left',-anchor => 'w', -fill => 'x');
  375.    $e->bind('<Return>',[$b => 'invoke']); 
  376.    $o->Button(-text => 'Clear', -command => sub { $o->{'url'} = "" })->pack(-side => 'left',-anchor => 'c', -fill => 'x');
  377.    $o->Button(-text => 'Current', -command => sub { $o->{'url'} = $w->url })->pack(-side => 'left',-anchor => 'c', -fill => 'x');
  378.    $o->Button(-text => 'Cancel', -command => [ withdraw => $o ])->pack(-side => 'right',-anchor => 'e',-fill => 'x');
  379.    $e->focus;
  380.   }
  381.  my $o = $w->{'Open'};
  382.  $o->{'url'}  = $w->url;
  383.  $o->Popup;
  384. }
  385.  
  386. sub SaveAs
  387. {
  388.  
  389. }
  390.  
  391. sub Home
  392. {
  393.  
  394. }
  395.  
  396. sub Stop
  397. {
  398.  
  399. }
  400.  
  401. sub Print
  402. {
  403.  
  404. }
  405.  
  406. sub Reload
  407. {
  408.  
  409. }
  410.  
  411. sub Find
  412. {
  413.  
  414. }
  415.  
  416. sub Back
  417. {
  418.  my ($w) = @_;
  419.  if (@{$w->{BACK}})
  420.   {
  421.    unshift(@{$w->{FORWARD}},$w->context);
  422.    $w->context(pop(@{$w->{BACK}}));
  423.   }
  424.  $w->break;
  425. }
  426.  
  427. sub Forward
  428. {
  429.  my ($w) = @_;
  430.  if (@{$w->{FORWARD}})
  431.   {
  432.    unshift(@{$w->{BACK}},$w->context);
  433.    $w->context(shift(@{$w->{FORWARD}}));
  434.   }
  435.  $w->break;
  436. }
  437.  
  438.  
  439.