Changeset 15713 for lang/perl

Show
Ignore:
Timestamp:
07/13/08 00:27:46 (5 years ago)
Author:
hio
Message:

WebClient?, 携帯ブラウザの対応.

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • lang/perl/tiarra/trunk/module/System/WebClient.pm

    r15702 r15713  
    2626our $VERSION = '0.05'; 
    2727 
    28 our $DEBUG = 0; 
     28our $DEBUG = 1; 
    2929 
    3030our $DEFAULT_MAX_LINES = 100; 
    … …  
    696696  if( !$sid ) 
    697697  { 
    698     $DEBUG and $this->_debug("$req->{peer}: _get_session: no sid"); 
    699     $req->{session} = {}; 
    700     return; 
     698    # check weak session. 
     699    my $cgi = $this->_get_cgi_hash($req); 
     700    my $w_sid = $cgi->{SID}; 
     701    my $sess = $w_sid && $this->{session_master}{$w_sid}; 
     702    if( $sess && $sess->{_weak} ) 
     703    { 
     704      # accept weak session. 
     705      $sid = $w_sid; 
     706      $req->{auth} = $w_sid; 
     707    }else 
     708    { 
     709      $DEBUG and $this->_debug("$req->{peer}: _update_session: no sid"); 
     710      $req->{session} = {}; 
     711      return; 
     712    } 
    701713  } 
    702714 
    … …  
    713725  } 
    714726 
    715   $sess->{_sid}        ||= $sid; 
    716   $sess->{_created_at} ||= $now; 
    717   $sess->{_expire}     ||= $DEFAULT_SESSION_EXPIRE; 
     727  if( !$sess->{_sid} ) 
     728  { 
     729    $sess->{_sid}        = $sid; 
     730    $sess->{_created_at} = $now; 
     731    $sess->{_expire}     = $DEFAULT_SESSION_EXPIRE; 
     732    $sess->{_weak}       = undef; 
     733  } 
    718734  $sess->{_updated_at} =   $now; 
    719735 
    … …  
    942958  if( my $name = $cgi->{n} ) 
    943959  { 
    944     $DEBUG and $this->_debug("$req->{peer}: _post_login: name=$name"); 
    945     $this->_new_session($req); # regen. 
    946     $req->{session}{name} = $name; 
    947     my $path = $cgi->{path} || "/";; 
    948     $this->_location($req, $path); 
    949     return 1; 
     960    if( $req->{Header}{Cookie} ) 
     961    { 
     962      $DEBUG and $this->_debug("$req->{peer}: _post_login: name=$name"); 
     963      $this->_new_session($req); # regen. 
     964      $req->{session}{name} = $name; 
     965      my $path = $cgi->{path} || "/"; 
     966      $this->_location($req, $path); 
     967      return 1; 
     968    } 
     969    if( $cgi->{weak} ) 
     970    { 
     971      $DEBUG and $this->_debug("$req->{peer}: _post_login: name=$name (weak session)"); 
     972      $this->_new_session($req); # regen. 
     973      $req->{session}{name}  = $name; 
     974      $req->{session}{_weak} = 1; 
     975      my $path = $cgi->{path} || "/"; 
     976      $this->_location($req, $path); 
     977      return 1; 
     978    } 
     979    $DEBUG and $this->_debug("$req->{peer}: _post_login: name=$name (no cookie)"); 
     980    return $this->_form_session($req); 
    950981  } 
    951982 
    … …  
    9961027} 
    9971028 
     1029sub _form_session 
     1030{ 
     1031  my $this = shift; 
     1032  my $req  = shift; 
     1033 
     1034  my $cgi = $this->_get_cgi_hash($req); 
     1035  my $name = $cgi->{n}; 
     1036  defined($name) or die "no cgi.name"; 
     1037 
     1038  my $tmpl = $this->_gen_form_session_html(); 
     1039  my $html = $this->_expand($req, $tmpl, { 
     1040    NAME        => $this->_escapeHTML($name), 
     1041    PATH        => '', 
     1042  }); 
     1043  $this->_response($req, [html=>$html]); 
     1044  1; 
     1045} 
     1046sub _gen_form_session_html 
     1047{ 
     1048  <<HTML; 
     1049<?xml version="1.0" encoding="utf-8" ?> 
     1050<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> 
     1051<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja-JP"> 
     1052<head> 
     1053  <meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> 
     1054  <meta http-equiv="Content-Style-Type"  content="text/css" /> 
     1055  <meta http-equiv="Content-Script-Type" content="text/javascript" /> 
     1056  <link rel="stylesheet" type="text/css" href="<&CSS>" /> 
     1057  <title>login (weak session)</title> 
     1058</head> 
     1059<body> 
     1060<div class="main"> 
     1061<div class="uatype-<&UA_TYPE>"> 
     1062 
     1063<h1>Login</h1> 
     1064 
     1065<form action="login" method="POST"> 
     1066名前: <input type="text" name="n" value="<&NAME>" /><br /> 
     1067<input type="submit" value="Login" /><br /> 
     1068<input type="hidden" name="path" value="<&PATH>" /> 
     1069(<label for="weak"><input type="checkbox" name="weak" id="weak" />(※)弱いセッションを使う</label>) 
     1070</form> 
     1071 
     1072<p> 
     1073(※) 携帯等Cookieの機能が使えない場合,  
     1074代替手段としてクエリにセッションIDを埋め込みます.<br /> 
     1075ログインしてもこのページが繰り返し表示されてしまう場合にのみ 
     1076チェックを入れてください. 
     1077</p> 
     1078 
     1079</div> 
     1080</div> 
     1081</body> 
     1082</html> 
     1083HTML 
     1084} 
     1085 
    9981086# ----------------------------------------------------------------------------- 
    9991087# $this->_dispatch($req). 
    … …  
    12511339  } 
    12521340 
     1341  if( $req->{session}{_weak} && ref($res) ) 
     1342  { 
     1343    # HTTPコードだけの場合はLocation等もナイので書き換えの必要はなし. 
     1344    $this->_rewrite_html($req, $res); 
     1345  } 
     1346 
    12531347  my $cli = $req->{client}; 
    12541348  $cli->response($res); 
    … …  
    12611355} 
    12621356 
     1357# ----------------------------------------------------------------------------- 
     1358# $this->_location($path). 
     1359# サイト内リダイレクト. 
     1360# weak-sessionであればSIDの付与は自動で行われる. 
     1361# 
    12631362sub _location 
    12641363{ 
    … …  
    12701369  $path = $this->{path} . $path; 
    12711370  $path =~ s{//+}{/}g; 
     1371  if( $req->{session}{_weak} ) 
     1372  { 
     1373    if( $path =~ /\?/ ) 
     1374    { 
     1375      $path .= "&SID=$req->{session}{_sid}"; 
     1376    }else 
     1377    { 
     1378      $path .= "?SID=$req->{session}{_sid}"; 
     1379    } 
     1380  } 
    12721381  my $res = { 
    12731382    Code => 302, 
    … …  
    12771386  }; 
    12781387  $this->_response($req, $res); 
     1388} 
     1389 
     1390# ----------------------------------------------------------------------------- 
     1391# $this->_rewrite_html($req, $res). 
     1392# weak-session時のHTML書き換え. 
     1393# 
     1394sub _rewrite_html 
     1395{ 
     1396  my $this = shift; 
     1397  my $req  = shift; 
     1398  my $res  = shift; 
     1399 
     1400  $req->{session}{_weak} or return; 
     1401 
     1402  my $sid_enc = $this->_escapeHTML($req->{session}{_sid}); 
     1403 
     1404  $res->{Content} =~ s{(<.*?>)}{ 
     1405    my $tag = $1; 
     1406    if( $tag =~ /^<form\b/ ) 
     1407    { 
     1408      $tag .= qq{<input type="hidden" name="SID" value="$sid_enc" />}; 
     1409    }else 
     1410    { 
     1411      $tag =~ s{\b(href|src)\s*=\s*(".*?"|[^\s>]*)}{ 
     1412        my ($key, $val) = ($1, $2); 
     1413        my $quoted   = $val =~ s/^"(.*)"\z/$1/s; 
     1414        my $fragment = $val =~ s/(#.*)//s ? $1 : ''; 
     1415        my ($path, $query) = split(/\?/, $val, 2); 
     1416        my @params; 
     1417        if( defined($query) ) 
     1418        { 
     1419          @params = split(/[&;]/, $query); 
     1420          foreach my $pair (@params) 
     1421          { 
     1422            my ($k, $v) = split(/=/, $pair, 2); 
     1423            $k =~ tr/+/ /; 
     1424            $k =~ s/%([0-9a-f]{2})/pack("H*",$1)/ge; 
     1425            if( $k eq 'SID' ) 
     1426            { 
     1427              $pair = undef; 
     1428            } 
     1429          } 
     1430          @params = grep{ defined($_) } @params; 
     1431        } 
     1432        push(@params, "SID=$sid_enc"); 
     1433        my $new_val = $path . '?' . join('&', @params); 
     1434        if( $quoted ) 
     1435        { 
     1436          $new_val = qq{"$new_val"}; 
     1437        } 
     1438        "$key=$new_val"; 
     1439      }ges; 
     1440    } 
     1441    $tag; 
     1442  }ges; 
     1443 
     1444  $res->{Header}{'Content-Length'} = length($res->{Content}); 
     1445 
     1446  $res; 
    12791447} 
    12801448