Hello MENTA world.

OS
Perl version
Perlのパス
モジュールパス	', map { escape_html $_ } @INC ?>
プロセスID

docroot
controller_dir

	{$key} \|\| '' ?>

").append(res.responseText.replace(//g,"")).find(selector):res.responseText);self.each(callback,[res.responseText,status,res]);}});return this;},serialize:function(){return jQuery.param(this.serializeArray());},serializeArray:function(){return this.map(function(){return jQuery.nodeName(this,"form")?jQuery.makeArray(this.elements):this;}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password/i.test(this.type));}).map(function(i,elem){var val=jQuery(this).val();return val==null?null:val.constructor==Array?jQuery.map(val,function(val,i){return{name:elem.name,value:val};}):{name:elem.name,value:val};}).get();}});jQuery.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(i,o){jQuery.fn[o]=function(f){return this.bind(o,f);};});var jsc=now();jQuery.extend({get:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data=null;}return jQuery.ajax({type:"GET",url:url,data:data,success:callback,dataType:type});},getScript:function(url,callback){return jQuery.get(url,null,callback,"script");},getJSON:function(url,data,callback){return jQuery.get(url,data,callback,"json");},post:function(url,data,callback,type){if(jQuery.isFunction(data)){callback=data;data={};}return jQuery.ajax({type:"POST",url:url,data:data,success:callback,dataType:type});},ajaxSetup:function(settings){jQuery.extend(jQuery.ajaxSettings,settings);},ajaxSettings:{url:location.href,global:true,type:"GET",timeout:0,contentType:"application/x-www-form-urlencoded",processData:true,async:true,data:null,username:null,password:null,accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(s){s=jQuery.extend(true,s,jQuery.extend(true,{},jQuery.ajaxSettings,s));var jsonp,jsre=/=\?(&|$)/g,status,data,type=s.type.toUpperCase();if(s.data&&s.processData&&typeof s.data!="string")s.data=jQuery.param(s.data);if(s.dataType=="jsonp"){if(type=="GET"){if(!s.url.match(jsre))s.url+=(s.url.match(/\?/)?"&":"?")+(s.jsonp||"callback")+"=?";}else if(!s.data||!s.data.match(jsre))s.data=(s.data?s.data+"&":"")+(s.jsonp||"callback")+"=?";s.dataType="json";}if(s.dataType=="json"&&(s.data&&s.data.match(jsre)||s.url.match(jsre))){jsonp="jsonp"+jsc++;if(s.data)s.data=(s.data+"").replace(jsre,"="+jsonp+"$1");s.url=s.url.replace(jsre,"="+jsonp+"$1");s.dataType="script";window[jsonp]=function(tmp){data=tmp;success();complete();window[jsonp]=undefined;try{delete window[jsonp];}catch(e){}if(head)head.removeChild(script);};}if(s.dataType=="script"&&s.cache==null)s.cache=false;if(s.cache===false&&type=="GET"){var ts=now();var ret=s.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+ts+"$2");s.url=ret+((ret==s.url)?(s.url.match(/\?/)?"&":"?")+"_="+ts:"");}if(s.data&&type=="GET"){s.url+=(s.url.match(/\?/)?"&":"?")+s.data;s.data=null;}if(s.global&&!jQuery.active++)jQuery.event.trigger("ajaxStart");var remote=/^(?:\w+:)?\/\/([^\/?#]+)/;if(s.dataType=="script"&&type=="GET"&&remote.test(s.url)&&remote.exec(s.url)[1]!=location.host){var head=document.getElementsByTagName("head")[0];var script=document.createElement("script");script.src=s.url;if(s.scriptCharset)script.charset=s.scriptCharset;if(!jsonp){var done=false;script.onload=script.onreadystatechange=function(){if(!done&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){done=true;success();complete();head.removeChild(script);}};}head.appendChild(script);return undefined;}var requestDone=false;var xhr=window.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest();if(s.username)xhr.open(type,s.url,s.async,s.username,s.password);else +xhr.open(type,s.url,s.async);try{if(s.data)xhr.setRequestHeader("Content-Type",s.contentType);if(s.ifModified)xhr.setRequestHeader("If-Modified-Since",jQuery.lastModified[s.url]||"Thu, 01 Jan 1970 00:00:00 GMT");xhr.setRequestHeader("X-Requested-With","XMLHttpRequest");xhr.setRequestHeader("Accept",s.dataType&&s.accepts[s.dataType]?s.accepts[s.dataType]+", */*":s.accepts._default);}catch(e){}if(s.beforeSend&&s.beforeSend(xhr,s)===false){s.global&&jQuery.active--;xhr.abort();return false;}if(s.global)jQuery.event.trigger("ajaxSend",[xhr,s]);var onreadystatechange=function(isTimeout){if(!requestDone&&xhr&&(xhr.readyState==4||isTimeout=="timeout")){requestDone=true;if(ival){clearInterval(ival);ival=null;}status=isTimeout=="timeout"&&"timeout"||!jQuery.httpSuccess(xhr)&&"error"||s.ifModified&&jQuery.httpNotModified(xhr,s.url)&&"notmodified"||"success";if(status=="success"){try{data=jQuery.httpData(xhr,s.dataType,s.dataFilter);}catch(e){status="parsererror";}}if(status=="success"){var modRes;try{modRes=xhr.getResponseHeader("Last-Modified");}catch(e){}if(s.ifModified&&modRes)jQuery.lastModified[s.url]=modRes;if(!jsonp)success();}else +jQuery.handleError(s,xhr,status);complete();if(s.async)xhr=null;}};if(s.async){var ival=setInterval(onreadystatechange,13);if(s.timeout>0)setTimeout(function(){if(xhr){xhr.abort();if(!requestDone)onreadystatechange("timeout");}},s.timeout);}try{xhr.send(s.data);}catch(e){jQuery.handleError(s,xhr,null,e);}if(!s.async)onreadystatechange();function success(){if(s.success)s.success(data,status);if(s.global)jQuery.event.trigger("ajaxSuccess",[xhr,s]);}function complete(){if(s.complete)s.complete(xhr,status);if(s.global)jQuery.event.trigger("ajaxComplete",[xhr,s]);if(s.global&&!--jQuery.active)jQuery.event.trigger("ajaxStop");}return xhr;},handleError:function(s,xhr,status,e){if(s.error)s.error(xhr,status,e);if(s.global)jQuery.event.trigger("ajaxError",[xhr,s,e]);},active:0,httpSuccess:function(xhr){try{return!xhr.status&&location.protocol=="file:"||(xhr.status>=200&&xhr.status<300)||xhr.status==304||xhr.status==1223||jQuery.browser.safari&&xhr.status==undefined;}catch(e){}return false;},httpNotModified:function(xhr,url){try{var xhrRes=xhr.getResponseHeader("Last-Modified");return xhr.status==304||xhrRes==jQuery.lastModified[url]||jQuery.browser.safari&&xhr.status==undefined;}catch(e){}return false;},httpData:function(xhr,type,filter){var ct=xhr.getResponseHeader("content-type"),xml=type=="xml"||!type&&ct&&ct.indexOf("xml")>=0,data=xml?xhr.responseXML:xhr.responseText;if(xml&&data.documentElement.tagName=="parsererror")throw"parsererror";if(filter)data=filter(data,type);if(type=="script")jQuery.globalEval(data);if(type=="json")data=eval("("+data+")");return data;},param:function(a){var s=[];if(a.constructor==Array||a.jquery)jQuery.each(a,function(){s.push(encodeURIComponent(this.name)+"="+encodeURIComponent(this.value));});else +for(var j in a)if(a[j]&&a[j].constructor==Array)jQuery.each(a[j],function(){s.push(encodeURIComponent(j)+"="+encodeURIComponent(this));});else +s.push(encodeURIComponent(j)+"="+encodeURIComponent(jQuery.isFunction(a[j])?a[j]():a[j]));return s.join("&").replace(/%20/g,"+");}});jQuery.fn.extend({show:function(speed,callback){return speed?this.animate({height:"show",width:"show",opacity:"show"},speed,callback):this.filter(":hidden").each(function(){this.style.display=this.oldblock||"";if(jQuery.css(this,"display")=="none"){var elem=jQuery("<"+this.tagName+" />").appendTo("body");this.style.display=elem.css("display");if(this.style.display=="none")this.style.display="block";elem.remove();}}).end();},hide:function(speed,callback){return speed?this.animate({height:"hide",width:"hide",opacity:"hide"},speed,callback):this.filter(":visible").each(function(){this.oldblock=this.oldblock||jQuery.css(this,"display");this.style.display="none";}).end();},_toggle:jQuery.fn.toggle,toggle:function(fn,fn2){return jQuery.isFunction(fn)&&jQuery.isFunction(fn2)?this._toggle.apply(this,arguments):fn?this.animate({height:"toggle",width:"toggle",opacity:"toggle"},fn,fn2):this.each(function(){jQuery(this)[jQuery(this).is(":hidden")?"show":"hide"]();});},slideDown:function(speed,callback){return this.animate({height:"show"},speed,callback);},slideUp:function(speed,callback){return this.animate({height:"hide"},speed,callback);},slideToggle:function(speed,callback){return this.animate({height:"toggle"},speed,callback);},fadeIn:function(speed,callback){return this.animate({opacity:"show"},speed,callback);},fadeOut:function(speed,callback){return this.animate({opacity:"hide"},speed,callback);},fadeTo:function(speed,to,callback){return this.animate({opacity:to},speed,callback);},animate:function(prop,speed,easing,callback){var optall=jQuery.speed(speed,easing,callback);return this[optall.queue===false?"each":"queue"](function(){if(this.nodeType!=1)return false;var opt=jQuery.extend({},optall),p,hidden=jQuery(this).is(":hidden"),self=this;for(p in prop){if(prop[p]=="hide"&&hidden||prop[p]=="show"&&!hidden)return opt.complete.call(this);if(p=="height"||p=="width"){opt.display=jQuery.css(this,"display");opt.overflow=this.style.overflow;}}if(opt.overflow!=null)this.style.overflow="hidden";opt.curAnim=jQuery.extend({},prop);jQuery.each(prop,function(name,val){var e=new jQuery.fx(self,opt,name);if(/toggle|show|hide/.test(val))e[val=="toggle"?hidden?"show":"hide":val](prop);else{var parts=val.toString().match(/^([+-]=)?([\d+-.]+)(.*)$/),start=e.cur(true)||0;if(parts){var end=parseFloat(parts[2]),unit=parts[3]||"px";if(unit!="px"){self.style[name]=(end||1)+unit;start=((end||1)/e.cur(true))*start;self.style[name]=start+unit;}if(parts[1])end=((parts[1]=="-="?-1:1)*end)+start;e.custom(start,end,unit);}else +e.custom(start,val,"");}});return true;});},queue:function(type,fn){if(jQuery.isFunction(type)||(type&&type.constructor==Array)){fn=type;type="fx";}if(!type||(typeof type=="string"&&!fn))return queue(this[0],type);return this.each(function(){if(fn.constructor==Array)queue(this,type,fn);else{queue(this,type).push(fn);if(queue(this,type).length==1)fn.call(this);}});},stop:function(clearQueue,gotoEnd){var timers=jQuery.timers;if(clearQueue)this.queue([]);this.each(function(){for(var i=timers.length-1;i>=0;i--)if(timers[i].elem==this){if(gotoEnd)timers[i](true);timers.splice(i,1);}});if(!gotoEnd)this.dequeue();return this;}});var queue=function(elem,type,array){if(elem){type=type||"fx";var q=jQuery.data(elem,type+"queue");if(!q||array)q=jQuery.data(elem,type+"queue",jQuery.makeArray(array));}return q;};jQuery.fn.dequeue=function(type){type=type||"fx";return this.each(function(){var q=queue(this,type);q.shift();if(q.length)q[0].call(this);});};jQuery.extend({speed:function(speed,easing,fn){var opt=speed&&speed.constructor==Object?speed:{complete:fn||!fn&&easing||jQuery.isFunction(speed)&&speed,duration:speed,easing:fn&&easing||easing&&easing.constructor!=Function&&easing};opt.duration=(opt.duration&&opt.duration.constructor==Number?opt.duration:jQuery.fx.speeds[opt.duration])||jQuery.fx.speeds.def;opt.old=opt.complete;opt.complete=function(){if(opt.queue!==false)jQuery(this).dequeue();if(jQuery.isFunction(opt.old))opt.old.call(this);};return opt;},easing:{linear:function(p,n,firstNum,diff){return firstNum+diff*p;},swing:function(p,n,firstNum,diff){return((-Math.cos(p*Math.PI)/2)+0.5)*diff+firstNum;}},timers:[],timerId:null,fx:function(elem,options,prop){this.options=options;this.elem=elem;this.prop=prop;if(!options.orig)options.orig={};}});jQuery.fx.prototype={update:function(){if(this.options.step)this.options.step.call(this.elem,this.now,this);(jQuery.fx.step[this.prop]||jQuery.fx.step._default)(this);if(this.prop=="height"||this.prop=="width")this.elem.style.display="block";},cur:function(force){if(this.elem[this.prop]!=null&&this.elem.style[this.prop]==null)return this.elem[this.prop];var r=parseFloat(jQuery.css(this.elem,this.prop,force));return r&&r>-10000?r:parseFloat(jQuery.curCSS(this.elem,this.prop))||0;},custom:function(from,to,unit){this.startTime=now();this.start=from;this.end=to;this.unit=unit||this.unit||"px";this.now=this.start;this.pos=this.state=0;this.update();var self=this;function t(gotoEnd){return self.step(gotoEnd);}t.elem=this.elem;jQuery.timers.push(t);if(jQuery.timerId==null){jQuery.timerId=setInterval(function(){var timers=jQuery.timers;for(var i=0;ithis.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var done=true;for(var i in this.options.curAnim)if(this.options.curAnim[i]!==true)done=false;if(done){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(jQuery.css(this.elem,"display")=="none")this.elem.style.display="block";}if(this.options.hide)this.elem.style.display="none";if(this.options.hide||this.options.show)for(var p in this.options.curAnim)jQuery.attr(this.elem.style,p,this.options.orig[p]);}if(done)this.options.complete.call(this.elem);return false;}else{var n=t-this.startTime;this.state=n/this.options.duration;this.pos=jQuery.easing[this.options.easing||(jQuery.easing.swing?"swing":"linear")](this.state,n,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update();}return true;}};jQuery.extend(jQuery.fx,{speeds:{slow:600,fast:200,def:400},step:{scrollLeft:function(fx){fx.elem.scrollLeft=fx.now;},scrollTop:function(fx){fx.elem.scrollTop=fx.now;},opacity:function(fx){jQuery.attr(fx.elem.style,"opacity",fx.now);},_default:function(fx){fx.elem.style[fx.prop]=fx.now+fx.unit;}}});jQuery.fn.offset=function(){var left=0,top=0,elem=this[0],results;if(elem)with(jQuery.browser){var parent=elem.parentNode,offsetChild=elem,offsetParent=elem.offsetParent,doc=elem.ownerDocument,safari2=safari&&parseInt(version)<522&&!/adobeair/i.test(userAgent),css=jQuery.curCSS,fixed=css(elem,"position")=="fixed";if(elem.getBoundingClientRect){var box=elem.getBoundingClientRect();add(box.left+Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),box.top+Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));add(-doc.documentElement.clientLeft,-doc.documentElement.clientTop);}else{add(elem.offsetLeft,elem.offsetTop);while(offsetParent){add(offsetParent.offsetLeft,offsetParent.offsetTop);if(mozilla&&!/^t(able|d|h)$/i.test(offsetParent.tagName)||safari&&!safari2)border(offsetParent);if(!fixed&&css(offsetParent,"position")=="fixed")fixed=true;offsetChild=/^body$/i.test(offsetParent.tagName)?offsetChild:offsetParent;offsetParent=offsetParent.offsetParent;}while(parent&&parent.tagName&&!/^body|html$/i.test(parent.tagName)){if(!/^inline|table.*$/i.test(css(parent,"display")))add(-parent.scrollLeft,-parent.scrollTop);if(mozilla&&css(parent,"overflow")!="visible")border(parent);parent=parent.parentNode;}if((safari2&&(fixed||css(offsetChild,"position")=="absolute"))||(mozilla&&css(offsetChild,"position")!="absolute"))add(-doc.body.offsetLeft,-doc.body.offsetTop);if(fixed)add(Math.max(doc.documentElement.scrollLeft,doc.body.scrollLeft),Math.max(doc.documentElement.scrollTop,doc.body.scrollTop));}results={top:top,left:left};}function border(elem){add(jQuery.curCSS(elem,"borderLeftWidth",true),jQuery.curCSS(elem,"borderTopWidth",true));}function add(l,t){left+=parseInt(l,10)||0;top+=parseInt(t,10)||0;}return results;};jQuery.fn.extend({position:function(){var left=0,top=0,results;if(this[0]){var offsetParent=this.offsetParent(),offset=this.offset(),parentOffset=/^body|html$/i.test(offsetParent[0].tagName)?{top:0,left:0}:offsetParent.offset();offset.top-=num(this,'marginTop');offset.left-=num(this,'marginLeft');parentOffset.top+=num(offsetParent,'borderTopWidth');parentOffset.left+=num(offsetParent,'borderLeftWidth');results={top:offset.top-parentOffset.top,left:offset.left-parentOffset.left};}return results;},offsetParent:function(){var offsetParent=this[0].offsetParent;while(offsetParent&&(!/^body|html$/i.test(offsetParent.tagName)&&jQuery.css(offsetParent,'position')=='static'))offsetParent=offsetParent.offsetParent;return jQuery(offsetParent);}});jQuery.each(['Left','Top'],function(i,name){var method='scroll'+name;jQuery.fn[method]=function(val){if(!this[0])return;return val!=undefined?this.each(function(){this==window||this==document?window.scrollTo(!i?val:jQuery(window).scrollLeft(),i?val:jQuery(window).scrollTop()):this[method]=val;}):this[0]==window||this[0]==document?self[i?'pageYOffset':'pageXOffset']||jQuery.boxModel&&document.documentElement[method]||document.body[method]:this[0][method];};});jQuery.each(["Height","Width"],function(i,name){var tl=i?"Left":"Top",br=i?"Right":"Bottom";jQuery.fn["inner"+name]=function(){return this[name.toLowerCase()]()+num(this,"padding"+tl)+num(this,"padding"+br);};jQuery.fn["outer"+name]=function(margin){return this["inner"+name]()+num(this,"border"+tl+"Width")+num(this,"border"+br+"Width")+(margin?num(this,"margin"+tl)+num(this,"margin"+br):0);};});})(); Index: lang/perl/MENTA/branches/henta/app/static/style-sites.css =================================================================== --- lang/perl/MENTA/branches/henta/app/static/style-sites.css (revision 25315) +++ lang/perl/MENTA/branches/henta/app/static/style-sites.css (revision 25315) @@ -0,0 +1,96 @@ +@charset "UTF-8"; + +body { + font-family: "ヒラギノ角ゴ ProN W3", "Hiragino Kaku Gothic ProN", + "ヒラギノ角ゴ Pro W3", "Hiragino Kaku Gothic Pro", + "メイリオ", "Meiryo", "Osaka", "ＭＳＰゴシック", + "Verdana", sans-serif; +} + +h1 { + padding: 0.5em; margin-top: 0; margin-bottom: 0; +} + +table { + border-style: solid; + border-width: 1px 0; +} + +th { + border-style: solid; + border-width: 0 0 1px; +} + +td { + padding: .5em; + border-style: solid; + border-width: 0 1px; +} + +pre { + padding-left: 2px; + border-width: 1px 1px 3px 3px; + border-style: solid; + border-color: #777777; + background: #555555; + color: white; +} + +.container { + width: 640px; + margin: auto; + padding: 0; +} + +.bodyContainer { + background-color: white; + padding-left: 4px; + padding-right: 4px; +} + +.subtitle { + background: transparent url(allow-right-orange.png) no-repeat scroll 0%; + padding-left: 26px; + line-height: 26px; + text-decoration: underline; +} + +.maintitle { + background: transparent url(allow-right-green.png) no-repeat scroll 0%; + padding-left: 26px; + line-height: 26px; + text-decoration: underline; +} + +.blocked-content { + padding: 1em; + border: 1px dotted gray; +} + +.markdown h2 { + background: transparent url(allow-right-orange.png) no-repeat scroll 0%; + padding-left: 26px; + line-height: 26px; + text-decoration: underline; +} + +.markdown p { + margin-left: 1em; +} + +.markdown pre { + margin-left: 1em; + border-bottom: 1px solid #777777; + border-left: 3px solid #777777; + border-right: 1px solid #777777; + border-top: 1px solid #777777; + font-family: monospace; + background: #555555; + color: white; + padding-left: 2px; + width: 100%; +} + +img { + border: 0 none; +} Index: lang/perl/MENTA/branches/henta/app/data/test =================================================================== --- lang/perl/MENTA/branches/henta/app/data/test (revision 25015) +++ lang/perl/MENTA/branches/henta/app/data/test (revision 25015) @@ -0,0 +1,1 @@ +11 Index: lang/perl/MENTA/branches/henta/app/data/counter.txt =================================================================== --- lang/perl/MENTA/branches/henta/app/data/counter.txt (revision 23981) +++ lang/perl/MENTA/branches/henta/app/data/counter.txt (revision 23981) @@ -0,0 +1,1 @@ +1078 Index: lang/perl/MENTA/branches/henta/plugins/bundle.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/bundle.pl (revision 25376) +++ lang/perl/MENTA/branches/henta/plugins/bundle.pl (revision 25376) @@ -0,0 +1,34 @@ +use UNIVERSAL::require; + +my @vers = ( + 'CGI::Simple' => '1.106', + 'Class::Accessor' => '0.31', + 'Class::Trigger' => '0.13', + 'Data::Page' => '2.01', + 'DateTime' => '0.45', + 'Email::MIME' => '1.861', + 'Email::Send' => '2.192', + 'Filter::SQL' => '0.10', + 'HTML::FillInForm' => '2.00', + 'HTML::StickyQuery::DoCoMoGUID' => '0.01', + 'HTML::TreeBuilder' => '3.23', + 'HTML::TreeBuilder::XPath' => '0.09', + 'HTTP::MobileAgent' => '0.27', + 'HTTP::Session' => '0.24', + 'JSON' => '2.12', + 'List::MoreUtils' => '0.22', + 'Params::Validate' => '0.91', + 'Path::Class' => '0.16', + 'Scalar::Util' => '1.19', + 'Text::CSV' => '1.10', + 'Text::Hatena' => '0.20', + 'Text::Markdown' => '1.0.24', + 'UNIVERSAL::require' => '0.11', + 'URI' => '1.37', + 'YAML' => '0.66', +); + +sub bundle_libs { + @vers +} + Index: lang/perl/MENTA/branches/henta/plugins/openid.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/openid.pl (revision 25521) +++ lang/perl/MENTA/branches/henta/plugins/openid.pl (revision 25521) @@ -0,0 +1,105 @@ +package MENTA::Plugin::OpenID; +use MENTA::Plugin; +use Net::OpenID::Consumer::Lite; + +my $OP_MAP = { + mixi => { + endpoint => 'https://mixi.jp/openid_server.pl', + nickname_fetcher => sub { + my $vident = shift; + $vident->{'sreg.nickname'}; + } + }, + livedoor => { + endpoint => 'https://auth.livedoor.com/openid/server', + nickname_fetcher => sub { + my $vident = shift; + my $identity = $vident->{identity} or die "identity がない？"; + if ($identity =~ m{^http://profile\.livedoor\.com/([^/]+)/$}) { + return $1; + } else { + die "不正なOpenID? : $identity"; + } + } + } +}; +my $ENDPOINT2NICKFETCHER = +{ map { $_->{endpoint} => $_->{nickname_fetcher} } values %$OP_MAP }; + +sub openid_get_user { + if (my $user = MENTA::session_get('plugin.openid.user')) { + return $user; + } else { + return undef; + } +} + +sub openid_login_url_map { + my %args_in = @_; + + my $args = {}; + for my $key (qw/cancelled verified/) { + $args->{$key} = delete $args_in{$key} or die "openid_make_login_url に $key が渡されていません"; + } + MENTA::session_set('plugin.openid._id_res' => $args); + + my $res; + for my $name (keys %$OP_MAP) { + $res->{$name} = MENTA::uri_for('plugin/openid/check_url', { op => $name }); + } + $res; +} + +sub do_check_url { + my $op = MENTA::param('op') or die "op の指定がないよ"; + my $server_url = $OP_MAP->{$op}->{endpoint} or die "知らない OP だ"; + my $check_url = Net::OpenID::Consumer::Lite->check_url( + $server_url, + "http://$ENV{SERVER_NAME}:$ENV{SERVER_PORT}" . MENTA::uri_for( 'plugin/openid/id_res', { back => 1, ret_url => MENTA::param('ret_url') } ), + { + "http://openid.net/extensions/sreg/1.1" => { required => join( ",", qw/email nickname/ ) } + } + ); + return MENTA::redirect($check_url); +} + +sub do_id_res { + my $req = MENTA->context->request; + my $params = +{ map { $_ => $req->param($_) } $req->param }; + my $option = MENTA::session_get('plugin.openid._id_res'); + my $cadir = $ENV{HTTPS_CA_DIR}; + local $ENV{HTTPS_CA_DIR}; + if ($cadir) { + $ENV{HTTPS_CA_DIR} = $cadir; + } elsif (-d '/etc/ssl/certs') { + $ENV{HTTPS_CA_DIR} = '/etc/ssl/certs'; + } + Net::OpenID::Consumer::Lite->handle_server_response( + $params => ( + not_openid => sub { + die "Not an OpenID message"; + }, + setup_required => sub { + my $setup_url = shift; + MENTA::redirect($setup_url); + }, + cancelled => sub { + MENTA::redirect($option->{cancelled}); + }, + verified => sub { + my $vident = shift; + my $identity = $vident->{identity}; + my $id = { + nickname => $ENDPOINT2NICKFETCHER->{$vident->{op_endpoint}}->( $vident ), + openid => $identity, + }; + MENTA::session_set('plugin.openid.user' => $id); + MENTA::redirect($option->{verified}); + }, + error => sub { + die "認証エラーです。SSL 通信に失敗しました: $@"; + }, + ) + ); +} + +1; Index: lang/perl/MENTA/branches/henta/plugins/counter.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/counter.pl (revision 24802) +++ lang/perl/MENTA/branches/henta/plugins/counter.pl (revision 24802) @@ -0,0 +1,22 @@ +package MENTA::Plugin::Counter; +use MENTA::Plugin; +use Fcntl ':flock', ':seek'; +use Carp; + +sub counter_increment { + my $fname = shift; + croak "ファイル名の指定がありません" unless $fname; + $fname = data_dir() . '/' . $fname; + my $mode = (-f $fname) ? '+<' : '+>'; + open my $fh, $mode, $fname or die "$fname を開けません: $!"; + flock $fh, LOCK_EX; + my $cnt = <$fh>; + $cnt++; + seek $fh, 0, SEEK_SET; + print $fh $cnt or die "$fname にかきこめません: $!"; + flock $fh, LOCK_UN; + close $fh or die "$fname を閉じることができません: $!"; + $cnt; +} + +1; Index: lang/perl/MENTA/branches/henta/plugins/file.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/file.pl (revision 24865) +++ lang/perl/MENTA/branches/henta/plugins/file.pl (revision 24865) @@ -0,0 +1,21 @@ +package MENTA::Plugin::File; +use MENTA::Plugin; + +sub file_read { + my $fname = shift; + open my $fh, '<:utf8', $fname + or die "${fname} を読み込み用に開けません: $!"; + my $s = do { local $/; join '', <$fh> }; + close $fh; + $s; +} + +sub file_write { + my ( $fname, $stuff ) = @_; + open my $fh, '>:utf8', $fname + or die "${fname} を書き込み用に開けません: $!"; + print $fh $stuff; + close $fh; +} + +1; Index: lang/perl/MENTA/branches/henta/plugins/sql.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/sql.pl (revision 24060) +++ lang/perl/MENTA/branches/henta/plugins/sql.pl (revision 24060) @@ -0,0 +1,75 @@ +package MENTA::Plugin::SQL; +use MENTA::Plugin; +use DBI; + +sub sql_dbh { + if (@_) { + my @args = @_; + if ($MENTA::STASH->{sql_dbh}) { + $MENTA::STASH->{sql_dbh}->disconnect; + undef $MENTA::STASH->{sql_dbh}; + } + my $dbh = DBI->connect(@args) or die "DBに接続できません: $DBI::errstr"; + $MENTA::STASH->{sql_dbh} = $dbh; + $dbh; + } else { + $MENTA::STASH->{sql_dbh} ||= do { + my $dsn = config->{application}->{sql}->{dsn} or die "設定に application.sql.dsn がありません"; + my $dbh = DBI->connect($dsn) or die "DBに接続できません: $DBI::errstr"; + $dbh->{unicode}++; + $dbh; + }; + } +} + +sub sql_prepare_exec { + my ($sql, @params) = @_; + my $dbh = sql_dbh(); + my $sth = $dbh->prepare($sql) or die "prepare できません: " . $dbh->errstr(); + $sth->execute(@params) or die "exec できません: " . $dbh->errstr; + $sth->finish(); + undef $sth; +} + +sub sql_select_all { + my ($sql, @params) = @_; + + my $dbh = sql_dbh(); + my $sth = $dbh->prepare($sql) or die $dbh->errstr; + $sth->execute(@params) or die $dbh->errstr; + my @res; + while (my $row = $sth->fetchrow_hashref) { + push @res, $row; + } + $sth->finish; + undef $sth; + + return \@res; +} + +sub sql_select_paginate { + my ($sql, $params, $paging) = @_; + $sql .= ' LIMIT ? OFFSET ?'; + + my $dbh = sql_dbh(); + my $sth = $dbh->prepare($sql) or die $dbh->errstr; + $sth->execute(@$params, $paging->{rows}+1, ($paging->{page}-1)*$paging->{rows}); + + my @res; + while (my $row = $sth->fetchrow_hashref) { + push @res, $row; + } + $sth->finish; + undef $sth; + + my $has_next = 0; + if ( @res == $paging->{rows} + 1 ) { + pop @res; + $has_next++; + } + + return (\@res, {page => $paging->{page}, has_next => $has_next, has_prev => ($paging->{page} == 1) ? 1 : 0}); +} + +1; +# AUTHOR: tokuhirom, mattn Index: lang/perl/MENTA/branches/henta/plugins/mail.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/mail.pl (revision 24060) +++ lang/perl/MENTA/branches/henta/plugins/mail.pl (revision 24060) @@ -0,0 +1,42 @@ +package MENTA::Plugin::Mail; +use MENTA::Plugin; +use Symbol (); + +# XXX windows で動かないかな。 +my $find_sendmail = sub { + for my $dir ( split /:/, $ENV{PATH} ) { + if ( -x "$dir/sendmail" ) { + return "$dir/sendmail"; + } + } + return; +}; + +sub mail_send { + my ($to, $subject, $body, $additional_headers) = @_; + die "To に改行を含めることはできません" if $to =~ /[\r\n]/; + + local $SIG{CHLD} = "DEFAULT"; + + my $mailer = $find_sendmail->() or die "sendmail が見つかりません"; + + my $pipe = Symbol::gensym(); + open $pipe, "| $mailer -t -oi" || die "$mailer を開けませんでした: $!"; + + my @lines; + push @lines, "To: $to\r\n"; + push @lines, $additional_headers if $additional_headers; + push @lines, "\r\n"; + push @lines, $body; + print $pipe join('', @lines) || die "$mailer に書き込めません: $!"; + + close $pipe || die "閉じれません: $mailer, $!"; +} + +1; +__END__ +# mb_send_mail('to@example.jp', 'サブジェクト', '本文', 'From: from@example.jp'); +# という風にして、送るとよい。 +# TODO: ヘッダの処理とかが甘いので、なんとかする +# iso-2022-jp に MIME encode する？ + Index: lang/perl/MENTA/branches/henta/plugins/cache.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/cache.pl (revision 24870) +++ lang/perl/MENTA/branches/henta/plugins/cache.pl (revision 24870) @@ -0,0 +1,20 @@ +package MENTA::Plugin::Cache; +use strict; +use warnings; +use Cache::FileCache; + +sub _cache { + MENTA->context->plugin_stash->{cache} ||= Cache::FileCache->new(); +} + +sub cache_get_callback { + my ($key, $code) = @_; + my $c = _cache(); + $c->get($key) || do { + my $dat = $code->(); + $c->set($key => $dat); + $dat; + }; +} + +1; Index: lang/perl/MENTA/branches/henta/plugins/session.pl =================================================================== --- lang/perl/MENTA/branches/henta/plugins/session.pl (revision 25521) +++ lang/perl/MENTA/branches/henta/plugins/session.pl (revision 25521) @@ -0,0 +1,77 @@ +package MENTA::Plugin::Session; +use MENTA::Plugin; +use HTTP::Session; +use HTTP::Session::Store::DBM; + +sub _postrun { + my ($app, $bodyref) = @_; + $app->session->header_filter($app); +} + +my $hooked; + +sub _create_state { + my $klass = MENTA::mobile_agent->is_non_mobile ? 'HTTP::Session::State::Cookie' : 'HTTP::Session::State::URI'; + $HTTP::Session::State::Cookie::COOKIE_CLASS = 'CGI::Simple::Cookie'; + (my $path = $klass) =~ s!::!/!og; + $path .= '.pm'; + MENTA::Util::require_once $path; + $klass->new(); +} + +sub _session { + $MENTA::STASH->{'plugin::session'} ||= sub { + my $session = HTTP::Session->new( + store => HTTP::Session::Store::DBM->new( + file => join('/', MENTA::data_dir(), 'session.dbm'), + ), + state => _create_state(), + request => MENTA->context->request(), + id => 'HTTP::Session::ID::MD5', + ); + unless ($hooked++) { + MENTA->add_trigger('BEFORE_OUTPUT' => sub { + $session->response_filter(MENTA->context->res); + $session->finalize; + }); + } + $session; + }->(); +} + +sub session_state_class { ref _session->state() } +sub session_store_class { ref _session->store() } + +sub session_logout_url { + my $back = shift || MENTA::docroot(); + + MENTA::Util::require_once('Digest/MD5.pm'); + my $csrfkey = Digest::MD5::md5_hex(rand() . session_session_id()); + session_set(csrf_key => $csrfkey); + session_set('plugin.session.logout_back', $back); + MENTA::uri_for('plugin/session/logout', {csrf_key => $csrfkey}); +} + +sub do_logout { + my $csrfkey = session_remove('csrf_key'); + warn $ENV{QUERY_STRING}; + unless ($ENV{QUERY_STRING} =~ /csrf_key=$csrfkey/) { + die "CSRF エラー"; + } + my $back = session_get('plugin.session.logout_back') || MENTA::docroot(); + session_expire(); + warn "REDIRECT TO $back"; + MENTA::redirect($back); +} + +{ + no strict 'refs'; + my $pkg = __PACKAGE__; + for my $meth (qw/get set keys remove as_hashref expire regenerate_session_id session_id/) { + *{"${pkg}::session_${meth}"} = sub { + _session()->$meth(@_); + }; + } +} + +1; Index: lang/perl/MENTA/branches/henta/AUTHORS =================================================================== --- lang/perl/MENTA/branches/henta/AUTHORS (revision 24242) +++ lang/perl/MENTA/branches/henta/AUTHORS (revision 24242) @@ -0,0 +1,7 @@ +Tokuhiro Matsuno +lestrrat +mattn +fujiwara +drry +hidek +kazuhooku Index: lang/perl/MENTA/branches/henta/Makefile.PL =================================================================== --- lang/perl/MENTA/branches/henta/Makefile.PL (revision 24788) +++ lang/perl/MENTA/branches/henta/Makefile.PL (revision 24788) @@ -0,0 +1,10 @@ +use inc::Module::Install; +name 'MENTA'; +all_from 'lib/MENTA.pm'; + +license 'perl'; + +tests 't/*.t t/*/*.t t/*/*/*.t t/*/*/*/*.t'; +use_test_base; +auto_include; +WriteAll; Index: lang/perl/MENTA/branches/henta/extlib/Test/YAML.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/Test/YAML.pm (revision 24144) +++ lang/perl/MENTA/branches/henta/extlib/Test/YAML.pm (revision 24144) @@ -0,0 +1,268 @@ +package Test::YAML; +use Test::Base 0.47 -Base; +use lib 'lib'; + +our $VERSION = '0.57'; + +our $YAML = 'YAML'; + +our @EXPORT = qw( + no_diff + run_yaml_tests + run_roundtrip_nyn roundtrip_nyn + run_load_passes load_passes + dumper Load Dump LoadFile DumpFile + XXX +); + +delimiters('===', '+++'); + +sub Dump() { YAML(Dump => @_) } +sub Load() { YAML(Load => @_) } +sub DumpFile() { YAML(DumpFile => @_) } +sub LoadFile() { YAML(LoadFile => @_) } + +sub YAML() { + load_yaml_pm(); + my $meth = shift; + my $code = $YAML->can($meth) or die "$YAML cannot do $meth"; + goto &$code; +} + +sub load_yaml_pm { + my $file = "$YAML.pm"; + $file =~ s{::}{/}g; + require $file; +} + +sub run_yaml_tests() { + run { + my $block = shift; + &{_get_function($block)}($block) unless + _skip_tests_for_now($block) or + _skip_yaml_tests($block); + }; +} + +sub run_roundtrip_nyn() { + my @options = @_; + run { + my $block = shift; + roundtrip_nyn($block, @options); + }; +} + +sub roundtrip_nyn() { + my $block = shift; + my $option = shift || ''; + die "'perl' data section required" + unless exists $block->{perl}; + my @values = eval $block->perl; + die "roundtrip_nyn eval perl error: $@" if $@; + my $config = $block->config || ''; + my $result = eval "$config; Dump(\@values)"; + die "roundtrip_nyn YAML::Dump error: $@" if $@; + if (exists $block->{yaml}) { + is $result, $block->yaml, + $block->description . ' (n->y)'; + } + else { + pass $block->description . ' (n->y)'; + } + + return if exists $block->{no_round_trip} or + not exists $block->{yaml}; + + if ($option eq 'dumper') { + is dumper(Load($block->yaml)), dumper(@values), + $block->description . ' (y->n)'; + } + else { + is_deeply [Load($block->yaml)], [@values], + $block->description . ' (y->n)'; + } +} + +sub count_roundtrip_nyn() { + my $block = shift or die "Bad call to count_roundtrip_nyn"; + return 1 if exists $block->{skip_this_for_now}; + my $count = 0; + $count++ if exists $block->{perl}; + $count++ unless exists $block->{no_round_trip} or + not exists $block->{yaml}; + die "Invalid test definition" unless $count; + return $count; +} + +sub run_load_passes() { + run { + my $block = shift; + my $yaml = $block->yaml; + eval { YAML(Load => $yaml) }; + is("$@", ""); + }; +} + +sub load_passes() { + my $block = shift; + my $yaml = $block->yaml; + eval { YAML(Load => $yaml) }; + is "$@", "", $block->description; +} + +sub count_load_passes() {1} + +sub dumper() { + require Data::Dumper; + $Data::Dumper::Sortkeys = 1; + $Data::Dumper::Terse = 1; + $Data::Dumper::Indent = 1; + return Data::Dumper::Dumper(@_); +} + +{ + no warnings; + sub XXX { + YAML::Base::XXX(@_); + } +} + +sub _count_tests() { + my $block = shift or die "Bad call to _count_tests"; + no strict 'refs'; + &{'count_' . _get_function_name($block)}($block); +} + +sub _get_function_name() { + my $block = shift; + return $block->function || 'roundtrip_nyn'; +} + +sub _get_function() { + my $block = shift; + no strict 'refs'; + \ &{_get_function_name($block)}; +} + +sub _skip_tests_for_now() { + my $block = shift; + if (exists $block->{skip_this_for_now}) { + _skip_test( + $block->description, + _count_tests($block), + ); + return 1; + } + return 0; +} + +sub _skip_yaml_tests() { + my $block = shift; + if ($block->skip_unless_modules) { + my @modules = split /[\s\,]+/, $block->skip_unless_modules; + for my $module (@modules) { + eval "require $module"; + if ($@) { + _skip_test( + "This test requires the '$module' module", + _count_tests($block), + ); + return 1; + } + } + } + return 0; +} + +sub _skip_test() { + my ($message, $count) = @_; + SKIP: { + skip($message, $count); + } +} + +#------------------------------------------------------------------------------- +package Test::YAML::Filter; +use base 'Test::Base::Filter'; + +sub yaml_dump { + Test::YAML::Dump(@_); +} + +sub yaml_load { + Test::YAML::Load(@_); +} + +sub Dump { goto &Test::YAML::Dump } +sub Load { goto &Test::YAML::Load } +sub DumpFile { goto &Test::YAML::DumpFile } +sub LoadFile { goto &Test::YAML::LoadFile } + +sub yaml_load_or_fail { + my ($result, $error, $warning) = + $self->_yaml_load_result_error_warning(@_); + return $error || $result; +} + +sub yaml_load_error_or_warning { + my ($result, $error, $warning) = + $self->_yaml_load_result_error_warning(@_); + return $error || $warning || ''; +} + +sub perl_eval_error_or_warning { + my ($result, $error, $warning) = + $self->_perl_eval_result_error_warning(@_); + return $error || $warning || ''; +} + +sub _yaml_load_result_error_warning { + $self->assert_scalar(@_); + my $yaml = shift; + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = join '', @_ }; + my $result = eval { + $self->yaml_load($yaml); + }; + return ($result, $@, $warning); +} + +sub _perl_eval_result_error_warning { + $self->assert_scalar(@_); + my $perl = shift; + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = join '', @_ }; + my $result = eval $perl; + return ($result, $@, $warning); +} + +1; + +=head1 NAME + +Test::YAML - Testing Module for YAML Implementations + +=head1 SYNOPSIS + + use Test::YAML tests => 1; + + pass; + +=head1 DESCRIPTION + +Test::YAML is a subclass of Test::Base with YAML specific support. + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT + +Copyright (c) 2006. Ingy döt Net. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut Index: lang/perl/MENTA/branches/henta/extlib/Return/Value.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/Return/Value.pm (revision 24147) +++ lang/perl/MENTA/branches/henta/extlib/Return/Value.pm (revision 24147) @@ -0,0 +1,345 @@ +use strict; +## no critic RequireUseWarnings +package Return::Value; +# vi:et:sw=4 ts=4 + +use vars qw[$VERSION @EXPORT]; ## no critic Export +$VERSION = '1.302'; +@EXPORT = qw[success failure]; + +use base qw[Exporter]; +use Carp (); + +=head1 NAME + +Return::Value - Polymorphic Return Values + +=head1 VERSION + +version 1.302 + + $Id: /my/cs/projects/return/trunk/lib/Return/Value.pm 28007 2006-11-14T22:21:03.864745Z rjbs $ + +=head1 SYNOPSIS + +Used with basic function-call interface: + + use Return::Value; + + sub send_over_network { + my ($net, $send) = @_: + if ( $net->transport( $send ) ) { + return success; + } else { + return failure "Was not able to transport info."; + } + } + + my $result = $net->send_over_network( "Data" ); + + # boolean + unless ( $result ) { + # string + print $result; + } + +Or, build your Return::Value as an object: + + sub build_up_return { + my $return = failure; + + if ( ! foo() ) { + $return->string("Can't foo!"); + return $return; + } + + if ( ! bar() ) { + $return->string("Can't bar"); + $return->prop(failures => \@bars); + return $return; + } + + # we're okay if we made it this far. + $return++; + return $return; # success! + } + +=head1 DESCRIPTION + +Polymorphic return values are really useful. Often, we just want to know if +something worked or not. Other times, we'd like to know what the error text +was. Still others, we may want to know what the error code was, and what the +error properties were. We don't want to handle objects or data structures for +every single return value, but we do want to check error conditions in our code +because that's what good programmers do. + +When functions are successful they may return true, or perhaps some useful +data. In the quest to provide consistent return values, this gets confusing +between complex, informational errors and successful return values. + +This module provides these features with a simple API that should get you what +you're looking for in each contex a return value is used in. + +=head2 Attributes + +All return values have a set of attributes that package up the information +returned. All attributes can be accessed or changed via methods of the same +name, unless otherwise noted. Many can also be accessed via overloaded +operations on the object, as noted below. + +=over 4 + +=item type + +A value's type is either "success" or "failure" and (obviously) reflects +whether the value is returning success or failure. + +=item errno + +The errno attribute stores the error number of the return value. For +success-type results, it is by default undefined. For other results, it +defaults to 1. + +=item string + +The value's string attribute is a simple message describing the value. + +=item data + +The data attribute stores a reference to a hash or array, and can be used as a +simple way to return extra data. Data stored in the data attribute can be +accessed by dereferencing the return value itself. (See below.) + +=item prop + +The most generic attribute of all, prop is a hashref that can be used to pass +an arbitrary number of data structures, just like the data attribute. Unlike +the data attribute, though, these structures must be retrived via method calls. + +=back + +=head1 FUNCTIONS + +The functional interface is highly recommended for use within functions +that are using C for return values. It's simple and +straightforward, and builds the entire return value in one statement. + +=over 4 + +=cut + +# This hack probably impacts performance more than I'd like to know, but it's +# needed to have a hashref object that can deref into a different hash. +# _ah($self,$key, [$value) sets or returns the value for the given key on the +# $self blessed-ref + +sub _ah { + my ($self, $key, $value) = @_; + my $class = ref $self; + bless $self => "ain't::overloaded"; + $self->{$key} = $value if @_ > 2; + my $return = $self->{$key}; + bless $self => $class; + return $return; +} + +sub _builder { + my %args = (type => shift); + $args{string} = shift if (@_ % 2); + %args = (%args, @_); + + $args{string} = $args{type} unless defined $args{string}; + + $args{errno} = ($args{type} eq 'success' ? undef : 1) + unless defined $args{errno}; + + __PACKAGE__->new(%args); +} + +=item success + +The C function returns a C with the type "success". + +Additional named parameters may be passed to set the returned object's +attributes. The first, optional, parameter is the string attribute and does +not need to be named. All other parameters must be passed by name. + + # simplest possible case + return success; + +=cut + +sub success { _builder('success', @_) } + +=pod + +=item failure + +C is identical to C, but returns an object with the type +"failure" + +=cut + +sub failure { _builder('failure', @_) } + +=pod + +=back + +=head1 METHODS + +The object API is useful in code that is catching C objects. + +=over 4 + +=item new + + my $return = Return::Value->new( + type => 'failure', + string => "YOU FAIL", + prop => { + failed_objects => \@objects, + }, + ); + +Creates a new C object. Named parameters can be used to set the +object's attributes. + +=cut + +sub new { + my $class = shift; + bless { type => 'failure', string => q{}, prop => {}, @_ } => $class; +} + +=pod + +=item bool + + print "it worked" if $result->bool; + +Returns the result in boolean context: true for success, false for failure. + +=item prop + + printf "%s: %s', + $result->string, join ' ', @{$result->prop('strings')} + unless $result->bool; + +Returns the return value's properties. Accepts the name of +a property retured, or returns the properties hash reference +if given no name. + +=item other attribute accessors + +Simple accessors exist for the object's other attributes: C, C, +C, and C. + +=cut + +sub bool { _ah($_[0],'type') eq 'success' ? 1 : 0 } + +sub type { + my ($self, $value) = @_; + return _ah($self, 'type') unless @_ > 1; + Carp::croak "invalid result type: $value" + unless $value eq 'success' or $value eq 'failure'; + return _ah($self, 'type', $value); +}; + +foreach my $name ( qw[errno string data] ) { + ## no critic (ProhibitNoStrict) + no strict 'refs'; + *{$name} = sub { + my ($self, $value) = @_; + return _ah($self, $name) unless @_ > 1; + return _ah($self, $name, $value); + }; +} + +sub prop { + my ($self, $name, $value) = @_; + return _ah($self, 'prop') unless $name; + return _ah($self, 'prop')->{$name} unless @_ > 2; + return _ah($self, 'prop')->{$name} = $value; +} + +=pod + +=back + +=head2 Overloading + +Several operators are overloaded for C objects. They are +listed here. + +=over 4 + +=item Stringification + + print "$result\n"; + +Stringifies to the string attribute. + +=item Boolean + + print $result unless $result; + +Returns the C representation. + +=item Numeric + +Also returns the C value. + +=item Dereference + +Dereferencing the value as a hash or array will return the value of the data +attribute, if it matches that type, or an empty reference otherwise. You can +check C<< ref $result->data >> to determine what kind of data (if any) was +passed. + +=cut + +use overload + '""' => sub { shift->string }, + 'bool' => sub { shift->bool }, + '==' => sub { shift->bool == shift }, + '!=' => sub { shift->bool != shift }, + '>' => sub { shift->bool > shift }, + '<' => sub { shift->bool < shift }, + 'eq' => sub { shift->string eq shift }, + 'ne' => sub { shift->string ne shift }, + 'gt' => sub { shift->string gt shift }, + 'lt' => sub { shift->string lt shift }, + '++' => sub { _ah(shift,'type','success') }, + '--' => sub { _ah(shift,'type','failure') }, + '${}' => sub { my $data = _ah($_[0],'data'); $data ? \$data : \undef }, + '%{}' => sub { ref _ah($_[0],'data') eq 'HASH' ? _ah($_[0],'data') : {} }, + '@{}' => sub { ref _ah($_[0],'data') eq 'ARRAY' ? _ah($_[0],'data') : [] }, + fallback => 1; + +=pod + +=back + +=head1 TODO + +No plans! + +=head1 AUTHORS + +Casey West, >. + +Ricardo Signes, >. + +=head1 COPYRIGHT + + Copyright (c) 2004-2006 Casey West and Ricardo SIGNES. All rights reserved. + This module is free software; you can redistribute it and/or modify it under + the same terms as Perl itself. + +=cut + +"This return value is true."; + +__END__ Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent.pm (revision 24282) @@ -0,0 +1,267 @@ +package HTTP::MobileAgent; + +use strict; +use vars qw($VERSION); +$VERSION = '0.27'; + +use HTTP::MobileAgent::Request; + +require HTTP::MobileAgent::DoCoMo; +require HTTP::MobileAgent::JPhone; +require HTTP::MobileAgent::EZweb; +require HTTP::MobileAgent::AirHPhone; +require HTTP::MobileAgent::NonMobile; +require HTTP::MobileAgent::Display; + +use vars qw($MobileAgentRE); +# this matching should be robust enough +# detailed analysis is done in subclass's parse() +my $DoCoMoRE = '^DoCoMo/\d\.\d[ /]'; +my $JPhoneRE = '^(?i:J-PHONE/\d\.\d)'; +my $VodafoneRE = '^Vodafone/\d\.\d'; +my $VodafoneMotRE = '^MOT-'; +my $SoftBankRE = '^SoftBank/\d\.\d'; +my $SoftBankCrawlerRE = '^Nokia[^/]+/\d\.\d'; +my $EZwebRE = '^(?:KDDI-[A-Z]+\d+[A-Z]? )?UP\.Browser\/'; +my $AirHRE = '^Mozilla/3\.0\((?:WILLCOM|DDIPOCKET)\;'; +$MobileAgentRE = qr/(?:($DoCoMoRE)|($JPhoneRE|$VodafoneRE|$VodafoneMotRE|$SoftBankRE|$SoftBankCrawlerRE)|($EZwebRE)|($AirHRE))/; + +sub new { + my($class, $stuff) = @_; + my $request = HTTP::MobileAgent::Request->new($stuff); + + # parse UA string + my $ua = $request->get('User-Agent'); + my $sub = 'NonMobile'; + if ($ua =~ /$MobileAgentRE/) { + $sub = $1 ? 'DoCoMo' : $2 ? 'JPhone' : $3 ? 'EZweb' : 'AirHPhone'; + } + + my $self = bless { _request => $request }, "$class\::$sub"; + $self->parse; + return $self; +} + + +sub user_agent { + my $self = shift; + $self->get_header('User-Agent'); +} + +sub get_header { + my($self, $header) = @_; + $self->{_request}->get($header); +} + +# should be implemented in subclasses +sub parse { die } +sub _make_display { die } + +sub name { shift->{name} } + +sub display { + my $self = shift; + unless ($self->{display}) { + $self->{display} = $self->_make_display; + } + return $self->{display}; +} + +# utility for subclasses +sub make_accessors { + my($class, @attr) = @_; + for my $attr (@attr) { + no strict 'refs'; + *{"$class\::$attr"} = sub { shift->{$attr} }; + } +} + +sub no_match { + my $self = shift; + require Carp; + Carp::carp($self->user_agent, ": no match. Might be new variants. ", + "please contact the author of HTTP::MobileAgent!") if $^W; +} + +sub is_docomo { 0 } +sub is_j_phone { 0 } +sub is_vodafone { 0 } +sub is_softbank { 0 } +sub is_ezweb { 0 } +sub is_airh_phone { 0 } +sub is_non_mobile { 0 } +sub is_tuka { 0 } + +sub is_wap1 { + my $self = shift; + $self->is_ezweb && ! $self->is_wap2; +} + +sub is_wap2 { + my $self = shift; + $self->is_ezweb && $self->xhtml_compliant; +} + +sub carrier { undef } +sub carrier_longname { undef } + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent - HTTP mobile user agent string parser + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + my $agent = HTTP::MobileAgent->new(Apache->request); + # or $agent = HTTP::MobileAgent->new; to get from %ENV + # or $agent = HTTP::MobileAgent->new($agent_string); + + if ($agent->is_docomo) { + # or if ($agent->name eq 'DoCoMo') + # or if ($agent->isa('HTTP::MobileAgent::DoCoMo')) + # it's NTT DoCoMo i-mode. + # see what's available in H::MA::DoCoMo + } elsif ($agent->is_vodafone) { + # it's Vodafone(J-Phone). + # see what's available in H::MA::Vodafone + } elsif ($agent->is_ezweb) { + # it's KDDI/EZWeb. + # see what's available in H::MA::EZweb + } else { + # may be PC + # $agent is H::MA::NonMobile + } + + my $display = $agent->display; # HTTP::MobileAgent::Display + if ($display->color) { ... } + +=head1 DESCRIPTION + +HTTP::MobileAgent parses HTTP_USER_AGENT strings of (mainly Japanese) +mobile HTTP user agents. It'll be useful in page dispatching by user agents. + +=head1 METHODS + +Here are common methods of HTTP::MobileAgent subclasses. More agent +specific methods are described in each subclasses. Note that some of +common methods are also overrided in some subclasses. + +=over 4 + +=item new + + $agent = HTTP::MobileAgent->new; + $agent = HTTP::MobileAgent->new($r); # Apache or HTTP::Request + $agent = HTTP::MobileAgent->new($ua_string); + +parses HTTP headers and constructs HTTP::MobileAgent subclass +instance. If no argument is supplied, $ENV{HTTP_*} is used. + +Note that you nees to pass Aapche or HTTP::Requet object to new(), as +some mobile agents put useful information on HTTP headers other than +only C (like C in J-Phone). + +=item user_agent + + print "User-Agent: ", $agent->user_agent; + +returns User-Agent string. + +=item name + + print "name: ", $agent->name; + +returns User-Agent name like 'DoCoMo'. + +=item is_docomo, is_vodafone(is_j_phone, is_softbank), is_ezweb, is_wap1, is_wap2, is_tuka,is_non_mobile + + if ($agent->is_docomo) { } + +returns if the agent is DoCoMo, Vodafone(J-Phone) or EZweb. + +=item carrier + + print "carrier: ", $agent->carrier; + +=item carrier_longname + + print "carrier_longname: ", $agent->carrier_longname; + +=item display + + my $display = $agent->display; + +returns HTTP::MobileAgent::Display object. See +L for details. + +=item user_id + + my $user_id = $agent->user_id; + +return X-DCMGUID, X-UP-SUBNO or X-JPHONE-UID. + +=back + +=head1 WARNINGS + +Following warnings might be raised when C<$^W> is on. + +=over 4 + +=item "%s: no match. Might be new variants. please contact the author of HTTP::MobileAgent!" + +User-Agent: string does not match patterns provided in subclasses. It +may be faked user-agent or a new variant. Feel free to mail me to +inform this. + +=back + +=head1 NOTE + +=over 4 + +=item "Why not adding this module as an extension of HTTP::BrowserDetect?" + +Yep, I tried to do. But the module's code seems hard enough for me to +extend and don't want to bother the author for this mobile-specific +features. So I made this module as a separated one. + +=back + +=head1 MORE IMPLEMENTATIONS + +If you have any idea / request for this module to add new subclass, +I'm open to the discussion or (more preferable) patches. Feel free to +mail me. + +=head1 OTHER LANGUAGE BINDINGS + +This module is now ported to PHP as Net::UserAgent::Mobile by Atsuhiro +KUBO. See http://pear.php.net/package-info.php?pacid=180 for details. + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE is the original author and wrote almost all the code. + +with contributions of Satoshi Tanimoto Etanimoto@cpan.orgE and Yoshiki Kurihara Ekurihara@cpan.orgE + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 MAIN + +=head1 SEE ALSO + +L, L, L, +L, L, +L, L + +Reference URL for specification is listed in Pods for each subclass. + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/GUID.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/GUID.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/GUID.pm (revision 24245) @@ -0,0 +1,94 @@ +package HTTP::Session::State::GUID; +use strict; +use warnings; +use base qw/HTTP::Session::State::MobileAttributeID/; +use HTML::StickyQuery::DoCoMoGUID; + +sub response_filter { + my ($self, $session_id, $res) = @_; + Carp::croak "missing session_id" unless $session_id; + + if ($res->code == 302) { + if (my $uri = $res->header('Location')) { + $res->header('Location' => $self->redirect_filter($session_id, $uri)); + } + return $res; + } elsif ($res->content) { + $res->content( $self->html_filter($session_id, $res->content) ); + return $res; + } else { + return $res; # nop + } +} + +sub html_filter { + my ($self, $session_id, $html) = @_; + Carp::croak "missing session_id" unless $session_id; + + my $sticky = HTML::StickyQuery::DoCoMoGUID->new; + return $sticky->sticky( + scalarref => \$html, + ); +} + +sub redirect_filter { + my ( $self, $session_id, $path ) = @_; + Carp::croak "missing session_id" unless $session_id; + + my $uri = URI->new($path); + $uri->query_form( $uri->query_form, guid => 'ON' ); + return $uri->as_string; +} + +1; +__END__ + +=head1 NAME + +HTTP::Session::State::GUID - Maintain session IDs using DoCoMo phone's unique id + +=head1 SYNOPSIS + + HTTP::Session->new( + state => HTTP::Session::State::GUID->new( + mobile_attribute => HTTP::MobileAttribute->new($r), + ), + store => ..., + request => ..., + ); + +=head1 DESCRIPTION + +Maintain session IDs using mobile phone's unique id + +=head1 CONFIGURATION + +=over 4 + +=item mobile_attribute + +instance of L + +=item check_ip + +check the IP address in the carrier's cidr/ or not? +see also L + +=back + +=head1 METHODS + +=over 4 + +=item get_session_id + +=item response_filter + +for internal use only + +=back + +=head1 SEE ALSO + +L, L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/MobileAttributeID.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/MobileAttributeID.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/MobileAttributeID.pm (revision 24245) @@ -0,0 +1,96 @@ +package HTTP::Session::State::MobileAttributeID; +use HTTP::Session::State::Base; +use HTTP::MobileAttribute plugins => [ + 'UserID', + 'CIDR', +]; + +__PACKAGE__->mk_ro_accessors(qw/mobile_attribute check_ip/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # check required parameters + for (qw/mobile_attribute/) { + Carp::croak "missing parameter $_" unless $args{$_}; + } + # set default values + $args{check_ip} = exists($args{check_ip}) ? $args{check_ip} : 1; + $args{permissive} = exists($args{permissive}) ? $args{permissive} : 1; + bless {%args}, $class; +} + +sub get_session_id { + my ($self, $req) = @_; + + my $ma = $self->mobile_attribute; + if ($ma->can('user_id')) { + if (my $user_id = $ma->user_id) { + if ($self->check_ip) { + my $ip = $ENV{REMOTE_ADDR} || $req->address || die "cannot get address"; + if (!$ma->isa_cidr($ip)) { + die "SECURITY: invalid ip($ip, $ma, $user_id)"; + } + } + return $user_id; + } else { + die "cannot detect mobile id from $ma"; + } + } else { + die "this carrier doesn't supports user_id: $ma"; + } +} + +sub response_filter { } + +1; +__END__ + +=head1 NAME + +HTTP::Session::State::MobileAttributeID - Maintain session IDs using mobile phone's unique id + +=head1 SYNOPSIS + + HTTP::Session->new( + state => HTTP::Session::State::MobileAttributeID->new( + mobile_attribute => HTTP::MobileAttribute->new($r), + ), + store => ..., + request => ..., + ); + +=head1 DESCRIPTION + +Maintain session IDs using mobile phone's unique id + +=head1 CONFIGURATION + +=over 4 + +=item mobile_attribute + +instance of L + +=item check_ip + +check the IP address in the carrier's cidr/ or not? +see also L + +=back + +=head1 METHODS + +=over 4 + +=item get_session_id + +=item response_filter + +for internal use only + +=back + +=head1 SEE ALSO + +L Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Cookie.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Cookie.pm (revision 24827) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Cookie.pm (revision 24827) @@ -0,0 +1,144 @@ +package HTTP::Session::State::Cookie; +use HTTP::Session::State::Base; +use Carp (); + +our $COOKIE_CLASS = 'CGI::Cookie'; + +__PACKAGE__->mk_ro_accessors(qw/name path domain expires/); + +{ + my $required = 0; + sub _cookie_class { + my $class = shift; + unless ($required) { + (my $klass = $COOKIE_CLASS) =~ s!::!/!g; + $klass .= ".pm"; + require $klass; + $required++; + } + return $COOKIE_CLASS + } +} + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # set default values + $args{name} ||= 'http_session_sid'; + $args{path} ||= '/'; + bless {%args}, $class; +} + +sub get_session_id { + my ($self, $req) = @_; + + my %jar = _cookie_class()->parse($ENV{HTTP_COOKIE} || $req->header('Cookie')); + my $cookie = $jar{$self->name}; + return $cookie ? $cookie->value : undef; +} + +sub response_filter { + my ($self, $session_id, $res) = @_; + Carp::croak "missing session_id" unless $session_id; + + $self->header_filter($session_id, $res); +} + +sub header_filter { + my ($self, $session_id, $res) = @_; + Carp::croak "missing session_id" unless $session_id; + + my $cookie = _cookie_class()->new( + sub { + my %options = ( + -name => $self->name, + -value => $session_id, + -path => $self->path, + ); + $options{'-domain'} = $self->domain if $self->domain; + $options{'-expires'} = $self->expires if $self->expires; + %options; + }->() + ); + $res->header( 'Set-Cookie' => $cookie->as_string ); +} + +1; +__END__ + +=head1 NAME + +HTTP::Session::State::Cookie - Maintain session IDs using cookies + +=head1 SYNOPSIS + + HTTP::Session->new( + state => HTTP::Session::State::Cookie->new( + name => 'foo_sid', + path => '/my/', + domain => 'example.com, + ), + store => ..., + request => ..., + ); + +=head1 DESCRIPTION + +Maintain session IDs using cookies + +=head1 CONFIGURATION + +=over 4 + +=item name + +cookie name. + + default: http_session_sid + +=item path + +path. + + default: / + +=item domain + + default: undef + +=item expires + +expire date.e.g. "+3M". +see also L. + + default: undef + +=back + +=head1 METHODS + +=over 4 + +=item header_filter($res) + +header filter + +=item get_session_id + +=item response_filter + +for internal use only + +=back + +=head1 HOW TO USE YOUR OWN CGI::Simple::Cookie? + + use HTTP::Session::State::Cookie; + BEGIN { + $HTTP::Session::State::Cookie::COOKIE_CLASS = 'CGI/Simple/Cookie.pm'; + } + +=head1 SEE ALSO + +L, L, L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Base.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Base.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Base.pm (revision 24245) @@ -0,0 +1,15 @@ +package HTTP::Session::State::Base; +use strict; +use warnings; +use Class::Accessor::Fast; + +sub import { + my $pkg = caller(0); + strict->import; + warnings->import; + no strict 'refs'; + unshift @{"${pkg}::ISA"}, "Class::Accessor::Fast"; + $pkg->mk_ro_accessors(qw/permissive/); +} + +1; Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Null.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Null.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Null.pm (revision 24245) @@ -0,0 +1,45 @@ +package HTTP::Session::State::Null; +use HTTP::Session::State::Base; + +sub get_session_id { } +sub response_filter { } + +1; +__END__ + +=head1 NAME + +HTTP::Session::State::Null - nop + +=head1 SYNOPSIS + + HTTP::Session->new( + state => HTTP::Session::State::Null->new(), + store => ..., + request => ..., + ); + +=head1 DESCRIPTION + +this is a dummy session state module =) + +=head1 CONFIGURATION + +nothing. + +=head1 METHODS + +=over 4 + +=item get_session_id + +=item response_filter + +for internal use only + +=back + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Test.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Test.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/Test.pm (revision 24245) @@ -0,0 +1,69 @@ +package HTTP::Session::State::Test; +use HTTP::Session::State::Base; + +__PACKAGE__->mk_ro_accessors(qw/session_id/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # check required parameters + for (qw/session_id/) { + Carp::croak "missing parameter $_" unless $args{$_}; + } + # set default values + bless {%args}, $class; +} + +sub get_session_id { + my $self = shift; + return $self->session_id; +} +sub response_filter { } + +1; +__END__ + +=head1 NAME + +HTTP::Session::State::Test - state module for testing + +=head1 SYNOPSIS + + HTTP::Session->new( + state => HTTP::Session::State::Test->new( + session_id => 'foobar', + ), + store => ..., + request => ..., + ); + +=head1 DESCRIPTION + +This is an mock object for testing session. + +=head1 CONFIGURATION + +=over 4 + +=item session_id + +dummy session id + +=back + +=head1 METHODS + +=over 4 + +=item get_session_id + +=item response_filter + +for internal use only + +=back + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/URI.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/URI.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/State/URI.pm (revision 24245) @@ -0,0 +1,122 @@ +package HTTP::Session::State::URI; +use HTTP::Session::State::Base; +use HTML::StickyQuery; + +__PACKAGE__->mk_ro_accessors(qw/session_id_name/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # set default values + $args{session_id_name} ||= 'sid'; + bless {%args}, $class; +} + +sub get_session_id { + my ($self, $req) = @_; + Carp::croak "missing req" unless $req; + $req->param($self->session_id_name); +} + +sub response_filter { + my ($self, $session_id, $res) = @_; + Carp::croak "missing session_id" unless $session_id; + + if ($res->code == 302) { + if (my $uri = $res->header('Location')) { + $res->header('Location' => $self->redirect_filter($session_id, $uri)); + } + return $res; + } elsif ($res->content) { + $res->content( $self->html_filter($session_id, $res->content) ); + return $res; + } else { + return $res; # nop + } +} + +sub html_filter { + my ($self, $session_id, $html) = @_; + Carp::croak "missing session_id" unless $session_id; + + my $session_id_name = $self->session_id_name; + + $html =~ s/()/$1\n/isg; + + my $sticky = HTML::StickyQuery->new; + return $sticky->sticky( + scalarref => \$html, + param => { $session_id_name => $session_id }, + ); +} + +sub redirect_filter { + my ( $self, $session_id, $path ) = @_; + Carp::croak "missing session_id" unless $session_id; + + my $uri = URI->new($path); + $uri->query_form( $uri->query_form, $self->session_id_name => $session_id ); + return $uri->as_string; +} + +1; +__END__ + +=head1 NAME + +HTTP::Session::State::URI - embed session id to uri + +=head1 SYNOPSIS + + HTTP::Session->new( + state => HTTP::Session::State::URI->new( + session_id_name => 'foo_sid', + ), + store => ..., + request => ..., + ); + +=head1 DESCRIPTION + +This state module embeds session id to uri. + +=head1 CONFIGURATION + +=over 4 + +=item session_id_name + +You can set the session id name. + + default: sid + +=back + +=head1 METHODS + +=over 4 + +=item html_filter($session_id, $html) + +HTML filter + +=item redirect_filter($session_id, $url) + +redirect filter + +=item get_session_id + +=item response_filter + +for internal use only + +=back + +=head1 WARNINGS + +URI sessions are very prone to session hijacking problems. + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/ID/MD5.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/ID/MD5.pm (revision 24462) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/ID/MD5.pm (revision 24462) @@ -0,0 +1,16 @@ +use warnings; +use strict; + +package HTTP::Session::ID::MD5; +use Digest::MD5 (); +use Time::HiRes (); + +# Digest::MD5 was first released with perl 5.007003 + +sub generate_id { + my ($class, $sid_length) = @_; + my $unique = $ENV{UNIQUE_ID} || ( [] . rand() ); + return substr( Digest::MD5::md5_hex( Time::HiRes::gettimeofday() . $unique ), 0, $sid_length ); +} + +1; Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/ID/SHA1.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/ID/SHA1.pm (revision 24462) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/ID/SHA1.pm (revision 24462) @@ -0,0 +1,14 @@ +use warnings; +use strict; + +package HTTP::Session::ID::SHA1; +use Digest::SHA1 (); +use Time::HiRes (); + +sub generate_id { + my ($class, $sid_length) = @_; + my $unique = $ENV{UNIQUE_ID} || ( [] . rand() ); + return substr( Digest::SHA1::sha1_hex( Time::HiRes::gettimeofday() . $unique ), 0, $sid_length ); +} + +1; Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/OnMemory.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/OnMemory.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/OnMemory.pm (revision 24245) @@ -0,0 +1,92 @@ +package HTTP::Session::Store::OnMemory; +use strict; +use warnings; +use base qw/Class::Accessor::Fast/; + +__PACKAGE__->mk_ro_accessors(qw/data/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # set default values + $args{data} ||= {}; + bless {%args}, $class; +} + +sub select { + my ( $self, $session_id ) = @_; + Carp::croak "missing session_id" unless $session_id; + $self->data->{$session_id}; +} + +sub insert { + my ($self, $session_id, $data) = @_; + Carp::croak "missing session_id" unless $session_id; + $self->data->{$session_id} = $data; +} + +sub update { + my ($self, $session_id, $data) = @_; + Carp::croak "missing session_id" unless $session_id; + $self->data->{$session_id} = $data; +} + +sub delete { + my ($self, $session_id) = @_; + Carp::croak "missing session_id" unless $session_id; + delete $self->data->{$session_id}; +} + +1; +__END__ + +=head1 NAME + +HTTP::Session::Store::OnMemory - store session data on memory + +=head1 SYNOPSIS + + HTTP::Session->new( + store => HTTP::Session::Store::OnMemory->new( + data => { + foo => 'bar', + } + ), + state => ..., + request => ..., + ); + +=head1 DESCRIPTION + +store session data on memory for testing + +=head1 CONFIGURATION + +=over 4 + +=item data + +session data. + +=back + +=head1 METHODS + +=over 4 + +=item select + +=item update + +=item delete + +=item insert + +for internal use only + +=back + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Memcached.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Memcached.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Memcached.pm (revision 24245) @@ -0,0 +1,95 @@ +package HTTP::Session::Store::Memcached; +use strict; +use warnings; +use base qw/Class::Accessor::Fast/; + +__PACKAGE__->mk_ro_accessors(qw/memd expires/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # check required parameters + for (qw/memd/) { + Carp::croak "missing parameter $_" unless $args{$_}; + } + unless (ref $args{memd} && index(ref($args{memd}), 'Memcached') >= 0) { + Carp::croak "memd requires instance of Cache::Memcached::Fast or Cache::Memcached"; + } + bless {%args}, $class; +} + +sub select { + my ( $self, $session_id ) = @_; + my $data = $self->memd->get($session_id); +} + +sub insert { + my ($self, $session_id, $data) = @_; + $self->memd->set( $session_id, $data, $self->expires ); +} + +sub update { + my ($self, $session_id, $data) = @_; + $self->memd->replace( $session_id, $data, $self->expires ); +} + +sub delete { + my ($self, $session_id) = @_; + $self->memd->delete( $session_id ); +} + +1; +__END__ + +=head1 NAME + +HTTP::Session::Store::Memcached - store session data in memcached + +=head1 SYNOPSIS + + HTTP::Session->new( + store => HTTP::Session::Store::Memcached->new( + memd => Cache::Memcached->new(servers => ['127.0.0.1:11211']), + ), + state => ..., + request => ..., + ); + +=head1 DESCRIPTION + +store session data in memcached + +=head1 CONFIGURATION + +=over 4 + +=item memd + +instance of Cache::Memcached or Cache::Memcached::Fast. + +=item expires + +session expire time(in seconds) + +=back + +=head1 METHODS + +=over 4 + +=item select + +=item update + +=item delete + +=item insert + +for internal use only + +=back + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Null.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Null.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Null.pm (revision 24245) @@ -0,0 +1,54 @@ +package HTTP::Session::Store::Null; +use strict; +use warnings; + +sub new { bless {}, shift } + +sub select { } +sub insert { } +sub update { } +sub delete { } + +1; +__END__ + +=head1 NAME + +HTTP::Session::Store::Null - dummy module for session store + +=head1 SYNOPSIS + + HTTP::Session->new( + store => HTTP::Session::Store::Null->new(), + state => ..., + request => ..., + ); + +=head1 DESCRIPTION + +dummy module for session store + +=head1 CONFIGURATION + +nop + +=head1 METHODS + +=over 4 + +=item select + +=item update + +=item delete + +=item insert + +for internal use only + +=back + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Test.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Test.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/Test.pm (revision 24245) @@ -0,0 +1,58 @@ +package HTTP::Session::Store::Test; +use strict; +use warnings; +use base qw/HTTP::Session::Store::OnMemory/; + +1; +__END__ + +=head1 NAME + +HTTP::Session::Store::Test - store session data on memory for testing + +=head1 SYNOPSIS + + HTTP::Session->new( + store => HTTP::Session::Store::Test->new( + data => { + foo => 'bar', + } + ), + state => ..., + request => ..., + ); + +=head1 DESCRIPTION + +store session data on memory for testing + +=head1 CONFIGURATION + +=over 4 + +=item data + +session data. + +=back + +=head1 METHODS + +=over 4 + +=item select + +=item update + +=item delete + +=item insert + +for internal use only + +=back + +=head1 SEE ALSO + +L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/DBM.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/DBM.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/DBM.pm (revision 24245) @@ -0,0 +1,49 @@ +package HTTP::Session::Store::DBM; +use strict; +use warnings; +use base qw/Class::Accessor::Fast/; +use Fcntl; +use Storable; +use UNIVERSAL::require; + +__PACKAGE__->mk_ro_accessors(qw/file dbm_class/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # check required parameters + for (qw/file/) { + Carp::croak "missing parameter $_" unless $args{$_}; + } + # set default values + $args{dbm_class} ||= 'SDBM_File'; + bless {%args}, $class; +} + +sub dbm { + my $self = shift; + $self->{dbm} ||= do { + my %hash; + $self->dbm_class->use or die $@; + tie %hash, $self->dbm_class, $self->file, O_CREAT | O_RDWR, oct("600"); + \%hash; + }; +} + +sub select { + my ( $self, $key ) = @_; + Storable::thaw $self->dbm->{$key}; +} + +sub insert { + my ( $self, $key, $value ) = @_; + $self->dbm->{$key} = Storable::freeze $value; +} +sub update { shift->insert(@_) } + +sub delete { + my ( $self, $key ) = @_; + delete $self->dbm->{$key}; +} + +1; Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/CHI.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/CHI.pm (revision 24245) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Session/Store/CHI.pm (revision 24245) @@ -0,0 +1,107 @@ +package HTTP::Session::Store::CHI; +use strict; +use warnings; +use base qw/Class::Accessor::Fast/; +use CHI; + +__PACKAGE__->mk_ro_accessors(qw/chi expires/); + +sub new { + my $class = shift; + my %args = ref($_[0]) ? %{$_[0]} : @_; + # check required parameters + for (qw/chi expires/) { + Carp::croak "missing parameter $_" unless $args{$_}; + } + # coerce + if (ref $args{chi} && ref $args{chi} eq 'HASH') { + $args{chi} = CHI->new(%{$args{chi}}); + } + bless {%args}, $class; +} + +sub select { + my ( $self, $session_id ) = @_; + my $data = $self->chi->get($session_id); +} + +sub insert { + my ($self, $session_id, $data) = @_; + $self->chi->set( $session_id, $data, $self->expires ); +} + +sub update { + my ($self, $session_id, $data) = @_; + $self->chi->set( $session_id, $data, $self->expires ); +} + +sub delete { + my ($self, $session_id) = @_; + $self->chi->remove( $session_id ); +} + +1; +__END__ + +=head1 NAME + +HTTP::Session::Store::CHI - store session data with CHI + +=head1 SYNOPSIS + + HTTP::Session->new( + store => HTTP::Session::Store::CHI->new( + chi => CHI->new(driver => 'memory'), + ), + state => ..., + request => ..., + ); + + # or + + HTTP::Session->new( + store => HTTP::Session::Store::CHI->new( + chi => {driver => 'memory'}, + ), + state => ..., + request => ..., + ); + +=head1 DESCRIPTION + +store session data with CHI + +=head1 CONFIGURATION + +=over 4 + +=item memd + +instance of CHI::Driver + +=item expires + +session expire time(in seconds) + +=back + +=head1 METHODS + +=over 4 + +=item select + +=item update + +=item delete + +=item insert + +for internal use only + +=back + +=head1 SEE ALSO + +L, L + Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/DoCoMoDisplayMap.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/DoCoMoDisplayMap.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/DoCoMoDisplayMap.pm (revision 24282) @@ -0,0 +1,1616 @@ +package HTTP::MobileAgent::DoCoMoDisplayMap; +# This file is autogenerated by makedocomomap +# in HTTP-MobileAgent distribution + +use strict; +require Exporter; +use base qw(Exporter); + +use vars qw(@EXPORT_OK $DisplayMap); +@EXPORT_OK = qw($DisplayMap); + +BEGIN { + if ($ENV{DOCOMO_MAP}) { + eval q{ + require XML::Simple; + my $xml = XML::Simple->new; + my $map = $xml->XMLin($ENV{DOCOMO_MAP}); + if ($map->{terminal}) { + # new layout + for my $terminal (@{$map->{terminal}}) { + my $model = delete $terminal->{model}; + $DisplayMap->{$model} = $terminal; + } + } + else { + # old layout + $DisplayMap = $map; + } + }; + warn "using normal hash map: $@" if $@; + } +} + +$DisplayMap ||= { + 'D209I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '90', + 'width' => '96' + }, + 'D2101V' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '130', + 'width' => '120' + }, + 'D210I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '91', + 'width' => '96' + }, + 'D211I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '91', + 'width' => '100' + }, + 'D251I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '144', + 'width' => '132' + }, + 'D251IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '144', + 'width' => '132' + }, + 'D252I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '198', + 'width' => '176' + }, + 'D253I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '198', + 'width' => '176' + }, + 'D253IWM' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '144', + 'width' => '220' + }, + 'D501I' => { + 'color' => '', + 'depth' => '2', + 'height' => '72', + 'width' => '96' + }, + 'D502I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '90', + 'width' => '96' + }, + 'D503I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '126', + 'width' => '132' + }, + 'D503IS' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '126', + 'width' => '132' + }, + 'D504I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '144', + 'width' => '132' + }, + 'D505I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'D505IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'D506I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'D701I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '240', + 'width' => '230' + }, + 'D701IWM' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '240', + 'width' => '230' + }, + 'D702I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D702IBCL' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D702IF' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D703I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D704I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'D705IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'D800IDS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D851IWM' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '230' + }, + 'D900I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'D901I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D901IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'D902I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '230' + }, + 'D902IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '230' + }, + 'D903I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '230' + }, + 'D903ITV' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '230' + }, + 'D904I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'D905I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '352', + 'width' => '240' + }, + 'ER209I' => { + 'color' => '', + 'depth' => '2', + 'height' => '72', + 'width' => '120' + }, + 'F2051' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '182', + 'width' => '176' + }, + 'F209I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '91', + 'width' => '96' + }, + 'F2102V' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '182', + 'width' => '176' + }, + 'F210I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '113', + 'width' => '96' + }, + 'F211I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '113', + 'width' => '96' + }, + 'F212I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '136', + 'width' => '132' + }, + 'F251I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '140', + 'width' => '132' + }, + 'F501I' => { + 'color' => '', + 'depth' => '2', + 'height' => '84', + 'width' => '112' + }, + 'F502I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '91', + 'width' => '96' + }, + 'F502IT' => { + 'color' => 1, + 'depth' => '256', + 'height' => '91', + 'width' => '96' + }, + 'F503I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '130', + 'width' => '120' + }, + 'F503IS' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '130', + 'width' => '120' + }, + 'F504I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '136', + 'width' => '132' + }, + 'F504IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '136', + 'width' => '132' + }, + 'F505I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '268', + 'width' => '240' + }, + 'F505IGPS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '268', + 'width' => '240' + }, + 'F506I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '268', + 'width' => '240' + }, + 'F661I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '136', + 'width' => '132' + }, + 'F671I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '126', + 'width' => '120' + }, + 'F671IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '120', + 'width' => '160' + }, + 'F672I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '120', + 'width' => '160' + }, + 'F700I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F700IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F702ID' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F703I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F704I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '352', + 'width' => '240' + }, + 'F801I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '352', + 'width' => '240' + }, + 'F880IES' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '256', + 'width' => '240' + }, + 'F881IES' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '256', + 'width' => '240' + }, + 'F882IES' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '256', + 'width' => '240' + }, + 'F883I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '256', + 'width' => '240' + }, + 'F883IES' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '256', + 'width' => '240' + }, + 'F900I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F900IC' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F900IT' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F901IC' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F901IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F902I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F902IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F903I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F903IBSC' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F903IX' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '230' + }, + 'F904I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '352', + 'width' => '240' + }, + 'F905I' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '352', + 'width' => '240' + }, + 'F905IBIZ' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '352', + 'width' => '240' + }, + 'KO209I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '96', + 'width' => '96' + }, + 'KO210I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '96', + 'width' => '96' + }, + 'L600I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '189', + 'width' => '170' + }, + 'L601I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '189', + 'width' => '170' + }, + 'L602I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '189', + 'width' => '170' + }, + 'L704I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '280', + 'width' => '240' + }, + 'L705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '280', + 'width' => '240' + }, + 'L705IX' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '280', + 'width' => '240' + }, + 'M702IG' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '267', + 'width' => '240' + }, + 'M702IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '267', + 'width' => '240' + }, + 'N2001' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '128', + 'width' => '118' + }, + 'N2002' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '128', + 'width' => '118' + }, + 'N2051' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '198', + 'width' => '176' + }, + 'N209I' => { + 'color' => '', + 'depth' => '4', + 'height' => '82', + 'width' => '108' + }, + 'N2102V' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '198', + 'width' => '176' + }, + 'N210I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '113', + 'width' => '118' + }, + 'N211I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '128', + 'width' => '118' + }, + 'N211IS' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '128', + 'width' => '118' + }, + 'N251I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '140', + 'width' => '132' + }, + 'N251IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '140', + 'width' => '132' + }, + 'N252I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '140', + 'width' => '132' + }, + 'N253I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '180', + 'width' => '160' + }, + 'N2701' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '198', + 'width' => '176' + }, + 'N501I' => { + 'color' => '', + 'depth' => '2', + 'height' => '128', + 'width' => '118' + }, + 'N502I' => { + 'color' => '', + 'depth' => '4', + 'height' => '128', + 'width' => '118' + }, + 'N502IT' => { + 'color' => 1, + 'depth' => '256', + 'height' => '128', + 'width' => '118' + }, + 'N503I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '128', + 'width' => '118' + }, + 'N503IS' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '128', + 'width' => '118' + }, + 'N504I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '180', + 'width' => '160' + }, + 'N504IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '180', + 'width' => '160' + }, + 'N505I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N505IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N506I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '295', + 'width' => '240' + }, + 'N506IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '295', + 'width' => '240' + }, + 'N506ISII' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '295', + 'width' => '240' + }, + 'N600I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '180', + 'width' => '176' + }, + 'N601I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N700I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N701I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N701IECO' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N702ID' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N702IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N703ID' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N703IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N704IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'N705IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'N821I' => { + 'color' => '', + 'depth' => '4', + 'height' => '128', + 'width' => '118' + }, + 'N900I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '269', + 'width' => '240' + }, + 'N900IG' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '269', + 'width' => '240' + }, + 'N900IL' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '269', + 'width' => '240' + }, + 'N900IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '269', + 'width' => '240' + }, + 'N901IC' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N901IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'N902I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N902IL' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N902IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N902IX' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N903I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'N904I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '352', + 'width' => '240' + }, + 'N905I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'N905IBIZ' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'N905IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'NM502I' => { + 'color' => '', + 'depth' => '2', + 'height' => '106', + 'width' => '111' + }, + 'NM705I' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '235', + 'width' => '231' + }, + 'NM850IG' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '176' + }, + 'P2002' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '128', + 'width' => '118' + }, + 'P209I' => { + 'color' => '', + 'depth' => '4', + 'height' => '87', + 'width' => '96' + }, + 'P209IS' => { + 'color' => 1, + 'depth' => '256', + 'height' => '87', + 'width' => '96' + }, + 'P2101V' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '182', + 'width' => '163' + }, + 'P2102V' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '198', + 'width' => '176' + }, + 'P210I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '91', + 'width' => '96' + }, + 'P211I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '130', + 'width' => '120' + }, + 'P211IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '130', + 'width' => '120' + }, + 'P213I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P251IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P252I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P252IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P253I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P253IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P501I' => { + 'color' => '', + 'depth' => '2', + 'height' => '120', + 'width' => '96' + }, + 'P502I' => { + 'color' => '', + 'depth' => '4', + 'height' => '117', + 'width' => '96' + }, + 'P503I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '130', + 'width' => '120' + }, + 'P503IS' => { + 'color' => 1, + 'depth' => '256', + 'height' => '130', + 'width' => '120' + }, + 'P504I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P504IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '144', + 'width' => '132' + }, + 'P505I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '266', + 'width' => '240' + }, + 'P505IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '266', + 'width' => '240' + }, + 'P506IC' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '266', + 'width' => '240' + }, + 'P506ICII' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '266', + 'width' => '240' + }, + 'P651PS' => { + 'color' => '', + 'depth' => '4', + 'height' => '87', + 'width' => '96' + }, + 'P700I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'P701ID' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'P702I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P702ID' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P703I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P703IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P704I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P704IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'P705ICL' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'P705IMYU' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'P821I' => { + 'color' => '', + 'depth' => '4', + 'height' => '128', + 'width' => '118' + }, + 'P851I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'P900I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '266', + 'width' => '240' + }, + 'P900IV' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '266', + 'width' => '240' + }, + 'P901I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'P901IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'P901ITV' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '270', + 'width' => '240' + }, + 'P902I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P902IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P903I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P903ITV' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'P903IX' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '270', + 'width' => '240' + }, + 'P904I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'P905I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'P905ITV' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '350', + 'width' => '240' + }, + 'R209I' => { + 'color' => '', + 'depth' => '4', + 'height' => '72', + 'width' => '96' + }, + 'R211I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '98', + 'width' => '96' + }, + 'R691I' => { + 'color' => '', + 'depth' => '4', + 'height' => '72', + 'width' => '96' + }, + 'R692I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '98', + 'width' => '96' + }, + 'SA700IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '252', + 'width' => '240' + }, + 'SA702I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '252', + 'width' => '240' + }, + 'SA800I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '252', + 'width' => '240' + }, + 'SH2101V' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '600', + 'width' => '800' + }, + 'SH251I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '130', + 'width' => '120' + }, + 'SH251IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '187', + 'width' => '176' + }, + 'SH252I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH505I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH505IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH506IC' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH700I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH700IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH702ID' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'SH702IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'SH703I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'SH704I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SH705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SH705III' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SH821I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '78', + 'width' => '96' + }, + 'SH851I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH900I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH901IC' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH901IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '252', + 'width' => '240' + }, + 'SH902I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'SH902IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'SH902ISL' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '240' + }, + 'SH903I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SH903ITV' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SH904I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SH905I' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '320', + 'width' => '240' + }, + 'SH905ITV' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '320', + 'width' => '240' + }, + 'SO210I' => { + 'color' => 1, + 'depth' => '256', + 'height' => '113', + 'width' => '120' + }, + 'SO211I' => { + 'color' => 1, + 'depth' => '4096', + 'height' => '112', + 'width' => '120' + }, + 'SO212I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '112', + 'width' => '120' + }, + 'SO213I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '112', + 'width' => '120' + }, + 'SO213IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '112', + 'width' => '120' + }, + 'SO213IWR' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '112', + 'width' => '120' + }, + 'SO502I' => { + 'color' => '', + 'depth' => '4', + 'height' => '120', + 'width' => '120' + }, + 'SO502IWM' => { + 'color' => 1, + 'depth' => '256', + 'height' => '113', + 'width' => '120' + }, + 'SO503I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '113', + 'width' => '120' + }, + 'SO503IS' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '113', + 'width' => '120' + }, + 'SO504I' => { + 'color' => 1, + 'depth' => '65536', + 'height' => '112', + 'width' => '120' + }, + 'SO505I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '240', + 'width' => '256' + }, + 'SO505IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO506I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO506IC' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO506IS' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO702I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO703I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '368', + 'width' => '240' + }, + 'SO704I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '368', + 'width' => '240' + }, + 'SO705I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '320', + 'width' => '240' + }, + 'SO902I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO902IWP+' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '256', + 'width' => '240' + }, + 'SO903I' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '368', + 'width' => '240' + }, + 'SO903ITV' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '368', + 'width' => '240' + }, + 'SO905I' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '368', + 'width' => '240' + }, + 'SO905ICS' => { + 'color' => 1, + 'depth' => '16777216', + 'height' => '368', + 'width' => '240' + }, + 'T2101V' => { + 'color' => 1, + 'depth' => '262144', + 'height' => '144', + 'width' => '176' + } +} +; + +1; Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Display.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Display.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Display.pm (revision 24282) @@ -0,0 +1,102 @@ +package HTTP::MobileAgent::Display; +use strict; +__PACKAGE__->HTTP::MobileAgent::make_accessors( + qw(width height color depth width_bytes height_bytes) +); + +use vars qw($VERSION); +$VERSION = 0.17; + +sub new { + my($class, %data) = @_; + bless {%data}, $class; +} + +sub size { + my $self = shift; + return wantarray ? ($self->width, $self->height) : $self->width * $self->height; +} + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent::Display - Display information for HTTP::MobileAgent + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + my $agent = HTTP::MobileAgent->new; + my $display = $agent->display; + + my $width = $display->width; + my $height = $display->height: + my($width, $height) = $display->size; + + if ($display->color) { + my $depth = $display->depth; + } + + # only available in DoCoMo 505i + my $width_bytes = $display->width_bytes; + my $height_bytes = $display->height_bytes; + +=head1 DESCRIPTION + +HTTP::MobileAgent::Display is a class for display information on +HTTP::MobileAgent. Handy for image resizing or dispatching. + +=head1 METHODS + +=over 4 + +=item width, height + + $width = $display->width; + $height = $display->height: + +returns width and height of the display. + +=item size + + ($width, $height) = $display->size; + $size = $display->size; + +returns width with height in array context, width * height in scalar context. + +=item color + + if ($display->color) { } + +returns true if it has color capability. + +=item depth + + $depth = $display->depth; + +returns color depth of the display. + +=head1 USING EXTERNAL MAP FILE + +If the environment variable DOCOMO_MAP exists, the specified XML data will be used for $DisplayMap. + +ex) Please add the following code. + + $ENV{DOCOMO_MAP} = '/path/to/DoCoMoMap.xml'; + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L, L + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Request.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Request.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Request.pm (revision 24282) @@ -0,0 +1,42 @@ +package HTTP::MobileAgent::Request; +use strict; + +sub new { + my($class, $stuff) = @_; + if (!defined $stuff) { + bless { env => \%ENV }, 'HTTP::MobileAgent::Request::Env'; + } + elsif (UNIVERSAL::isa($stuff, 'Apache')) { + bless { r => $stuff }, 'HTTP::MobileAgent::Request::Apache'; + } + elsif (UNIVERSAL::isa($stuff, 'HTTP::Headers')) { + bless { r => $stuff }, 'HTTP::MobileAgent::Request::HTTPHeaders'; + } + else { + bless { env => { HTTP_USER_AGENT => $stuff } }, 'HTTP::MobileAgent::Request::Env'; + } +} + +package HTTP::MobileAgent::Request::Env; + +sub get { + my($self, $header) = @_; + $header =~ tr/-/_/; + return $self->{env}->{"HTTP_" . uc($header)}; +} + +package HTTP::MobileAgent::Request::Apache; + +sub get { + my($self, $header) = @_; + return $self->{r}->header_in($header); +} + +package HTTP::MobileAgent::Request::HTTPHeaders; + +sub get { + my($self, $header) = @_; + return $self->{r}->header($header); +} + +1; Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/EZweb.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/EZweb.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/EZweb.pm (revision 24282) @@ -0,0 +1,192 @@ +package HTTP::MobileAgent::EZweb; + +use strict; +use vars qw($VERSION); +$VERSION = 0.20; + +use base qw(HTTP::MobileAgent); + +__PACKAGE__->make_accessors( + qw(version model device_id server xhtml_compliant comment) +); + +sub is_ezweb { 1 } + +sub carrier { 'E' } + +sub carrier_longname { 'EZweb' } + +sub is_tuka { + my $self = shift; + my $tuka = substr($self->device_id, 2, 1); + if($self->is_wap2){ + return 1 if $tuka eq 'U'; + } else { + return 1 if $tuka eq 'T'; + } + return; +} + +sub is_win { + my $self = shift; + my $win = substr($self->device_id, 2, 1); + $win eq '3' ? 1 : 0; +} + +sub parse { + my $self = shift; + my $ua = $self->user_agent; + if ($ua =~ s/^KDDI\-//) { + # KDDI-TS21 UP.Browser/6.0.2.276 (GUI) MMP/1.1 + $self->{xhtml_compliant} = 1; + my($device, $browser, $opt, $server) = split / /, $ua, 4; + $self->{device_id} = $device; + + my($name, $version) = split m!/!, $browser; + $self->{name} = $name; + $self->{version} = "$version $opt"; + $self->{server} = $server; + } + else { + # UP.Browser/3.01-HI01 UP.Link/3.4.5.2 + my($browser, $server, $comment) = split / /, $ua, 3; + my($name, $software) = split m!/!, $browser; + $self->{name} = $name; + @{$self}{qw(version device_id)} = split /-/, $software; + $self->{server} = $server; + if ($comment) { + $comment =~ s/^$(.*)$$/$1/; + $self->{comment} = $comment; + } + } + $self->{model} = $self->{device_id}; +} + +sub _make_display { + my $self = shift; + my($width, $height) = split /,/, $self->get_header('x-up-devcap-screenpixels'); + my $depth = (split /,/, $self->get_header('x-up-devcap-screendepth'))[0]; + my $color = $self->get_header('x-up-devcap-iscolor'); + return HTTP::MobileAgent::Display->new( + width => $width, + height => $height, + color => (defined $color && $color eq '1'), + depth => 2 ** $depth, + ); +} + +sub user_id { + my $self = shift; + return $self->get_header( 'x-up-subno' ); +} + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent::EZweb - EZweb implementation + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + local $ENV{HTTP_USER_AGENT} = "UP.Browser/3.01-HI02 UP.Link/3.2.1.2"; + my $agent = HTTP::MobileAgent->new; + + printf "Name: %s\n", $agent->name; # "UP.Browser" + printf "Version: %s\n", $agent->version; # 3.01 + printf "DevieID: %s\n", $agent->device_id; # HI02 + printf "Server: %s\n", $agent->server; # "UP.Link/3.2.1.2" + + # e.g.) UP.Browser/3.01-HI02 UP.Link/3.2.1.2 (Google WAP Proxy/1.0) + printf "Comment: %s\n", $agent->comment; # "Google WAP Proxy/1.0" + + # e.g.) KDDI-TS21 UP.Browser/6.0.2.276 (GUI) MMP/1.1 + print "XHTML compiant!\n" if $agent->xhtml_compliant; # true + +=head1 DESCRIPTION + +HTTP::MobileAgent::EZweb is a subclass of HTTP::MobileAgent, which +implements EZweb (WAP1.0/2.0) user agents. + +=head1 METHODS + +See L for common methods. Here are +HTTP::MobileAgent::EZweb specific methods. + +=over 4 + +=item version + + $version = $agent->version; + +returns UP.Browser version number like '3.01'. + +=item device_id + + $device_id = $agent->device_id; + +returns device ID like 'TS21'. + +=item server + + $server = $agent->server; + +returns server string like "UP.Link/3.2.1.2". + +=item comment + + $comment = $agent->comment; + +returns comment like "Google WAP Proxy/1.0". returns undef if nothinng. + +=item xhtml_compliant + + if ($agent->xhtml_compliant) { } + +returns if the agent is XHTML compliant. + +=item is_tuka + + if ($agent->is_tuka) { } + +returns if the agent is TU-KA model. + +=item is_win + + if ($agent->is_win) { } + +returns if the agent is win model. + +=back + +=head1 TODO + +=over 4 + +=item * + +Spec information support listed in +http://www.au.kddi.com/ezfactory/tec/spec/new_win/ezkishu.html + +(Patches are always welcome ;)) + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +http://www.au.kddi.com/ezfactory/tec/spec/4_4.html + +http://www.au.kddi.com/ezfactory/tec/spec/new_win/ezkishu.html + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/AirHPhone.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/AirHPhone.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/AirHPhone.pm (revision 24282) @@ -0,0 +1,114 @@ +package HTTP::MobileAgent::AirHPhone; + +use strict; +use vars qw($VERSION); +$VERSION = 0.21; + +use base qw(HTTP::MobileAgent); + +__PACKAGE__->make_accessors( + qw(vendor model model_version browser_version cache_size) +); + +sub is_airh_phone { 1 } + +sub carrier { 'H' } + +sub carrier_longname { 'AirH' } + +sub parse { + my $self = shift; + my $ua = $self->user_agent; + $ua =~ m!^Mozilla/3\.0$(WILLCOM|DDIPOCKET);(.*)$! or return $self->no_match; + $self->{name} = $1; + @{$self}{qw(vendor model model_version browser_version cache_size)} = split m!/!, $2; + $self->{cache_size} =~ s/^c//i; +} + +sub _make_display { + # XXX +} + +sub user_id { + # XXX +} + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent::AirHPhone - Air H" Phone implementation + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + local $ENV{HTTP_USER_AGENT} = "Mozilla/3.0(DDIPOCKET;JRC/AH-J3001V,AH-J3002V/1.0/0100/c50)CNF/2.0"; + my $agent = HTTP::MobileAgent->new; + + printf "Name: %s\n", $agent->name; # DDIPOCKET + printf "Vendor: %s\n", $agent->vendor; # JRC + printf "Model: %s\n", $agent->model; # AH-J3001V,AH-J3002V + printf "Model Version: %s\n", $agent->model_version; # 1.0 + printf "Browser Version: %s\n", $agent->browser_version; # 0100 + printf "Cache Size: %s\n", $agent->cache_size; # 50 + +=head1 DESCRIPTION + +HTTP::MobileAgent::AirHPhone is a subclass of HTTP::MobileAgent, which +implements DDIPocket's Air H" Phone user agents. + +=head1 METHODS + +See L for common methods. Here are +HTTP::MobileAgent::AirHPhone specific methods. + +=over 4 + +=item vendor + + $vendor = $agent->vendor; + +returns vendor name. + +=item model + + $model = $agent->model; + +returns model name. Note that model names are separated with ','. + +=item model_version + + $model_ver = $agent->model_version; + +returns version number of the model. + +=item browser_version + + $browser_ver = $agent->browser_version; + +returns versino number of the browser. + +=item cache_size + + $cache_size = $agent->cache_size; + +returns cache size with kilobyte unit. + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +http://www.ddipocket.co.jp/airh_phone/i_hp.html + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/DoCoMo.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/DoCoMo.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/DoCoMo.pm (revision 24282) @@ -0,0 +1,326 @@ +package HTTP::MobileAgent::DoCoMo; + +use strict; +use vars qw($VERSION); +$VERSION = 0.19; + +use base qw(HTTP::MobileAgent); + +__PACKAGE__->make_accessors( + qw(version model status bandwidth + serial_number is_foma card_id xhtml_compliant comment) +); + +use HTTP::MobileAgent::DoCoMoDisplayMap qw($DisplayMap); + +# various preferences +use vars qw($DefaultCacheSize $HTMLVerMap $GPSModels); +$DefaultCacheSize = 5; + +# http://www.nttdocomo.co.jp/service/imode/make/content/spec/useragent/ +$HTMLVerMap = [ + # regex => version + qr/[DFNP]501i/ => '1.0', + qr/502i|821i|209i|691i|(F|N|P|KO)210i|^F671i$/ => '2.0', + qr/(D210i|SO210i)|503i|211i|SH251i|692i|200[12]|2101V/ => '3.0', + qr/504i|251i|^F671iS$|^F661i$|^F672i$|212i|SO213i|2051|2102V|2701|850i/ => '4.0', + qr/eggy|P751v/ => '3.2', + qr/505i|506i|252i|253i|P213i|600i|700i|701i|800i|880i|SH851i|P851i|881i|900i|901i/ => '5.0', + qr/702i|D851iWM|902i/ => '6.0', +]; + +$GPSModels = { map { $_ => 1 } qw(F661i F505iGPS) }; + +sub is_docomo { 1 } + +sub carrier { 'I' } + +sub carrier_longname { 'DoCoMo' } + +sub parse { + my $self = shift; + my($main, $foma_or_comment) = split / /, $self->user_agent, 2; + + if ($foma_or_comment && $foma_or_comment =~ s/^$(.*)$$/$1/) { + # DoCoMo/1.0/P209is (Google CHTML Proxy/1.0) + $self->{comment} = $1; + $self->_parse_main($main); + } elsif ($foma_or_comment) { + # DoCoMo/2.0 N2001(c10;ser0123456789abcde;icc01234567890123456789) + $self->{is_foma} = 1; + @{$self}{qw(name version)} = split m!/!, $main; + $self->_parse_foma($foma_or_comment); + } else { + # DoCoMo/1.0/R692i/c10 + $self->_parse_main($main); + } + + $self->{xhtml_compliant} = + ( $self->is_foma && !( $self->html_version && $self->html_version == 3.0 ) ) + ? 1 + : 0; +} + +sub _parse_main { + my($self, $main) = @_; + my($name, $version, $model, $cache, @rest) = split m!/!, $main; + $self->{name} = $name; + $self->{version} = $version; + $self->{model} = $model; + $self->{model} = 'SH505i' if $self->{model} eq 'SH505i2'; + + if ($cache) { + $cache =~ s/^c// or return $self->no_match; + $self->{cache_size} = $cache; + } + + for (@rest) { + /^ser(\w{11})$/ and do { $self->{serial_number} = $1; next }; + /^(T[CDBJ])$/ and do { $self->{status} = $1; next }; + /^s(\d+)$/ and do { $self->{bandwidth} = $1; next }; + /^W(\d+)H(\d+)$/ and do { $self->{display_bytes} = "$1*$2"; next; }; + } +} + +sub _parse_foma { + my($self, $foma) = @_; + + $foma =~ s/^([^$]+)// or return $self->no_match; + $self->{model} = $1; + $self->{model} = 'SH2101V' if $1 eq 'MST_v_SH2101V'; # Huh? + + if ($foma =~ s/^\((.*?)$$//) { + my @options = split /;/, $1; + for (@options) { + /^c(\d+)$/ and $self->{cache_size} = $1, next; + /^ser(\w{15})$/ and $self->{serial_number} = $1, next; + /^icc(\w{20})$/ and $self->{card_id} = $1, next; + /^(T[CDBJ])$/ and $self->{status} = $1, next; + /^W(\d+)H(\d+)$/ and $self->{display_bytes} = "$1*$2", next; + $self->no_match; + } + } +} + +sub html_version { + my $self = shift; + + my @map = @$HTMLVerMap; + while (my($re, $version) = splice(@map, 0, 2)) { + return $version if $self->model =~ /$re/; + } + return undef; +} + +sub cache_size { + my $self = shift; + return $self->{cache_size} || $DefaultCacheSize; +} + +sub series { + my $self = shift; + my $model = $self->model; + + if ($self->is_foma && $model =~ /\d{4}/) { + return 'FOMA'; + } + + $model =~ /(\d{3}i)/; + return $1; +} + +sub vendor { + my $self = shift; + my $model = $self->model; + $model =~ /^([A-Z]+)\d/; + return $1; +} + +sub _make_display { + my $self = shift; + my $display = $DisplayMap->{uc($self->model)}; + if ($self->{display_bytes}) { + my($w, $h) = split /\*/, $self->{display_bytes}; + $display->{width_bytes} = $w; + $display->{height_bytes} = $h; + } + return HTTP::MobileAgent::Display->new(%$display); +} + +sub is_gps { + my $self = shift; + return exists $GPSModels->{$self->model}; +} + +sub user_id { + my $self = shift; + return $self->get_header( 'x-dcmguid' ); +} + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent::DoCoMo - NTT DoCoMo implementation + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + local $ENV{HTTP_USER_AGENT} = "DoCoMo/1.0/P502i/c10"; + my $agent = HTTP::MobileAgent->new; + + printf "Name: %s\n", $agent->name; # "DoCoMo" + printf "Ver: %s\n", $agent->version; # 1.0 + printf "HTML ver: %s\n", $agent->html_version; # 2.0 + printf "Model: %s\n", $agent->model; # "P502i" + printf "Cache: %dk\n", $agent->cache_size; # 10 + print "FOMA\n" if $agent->is_foma; # false + printf "Vendor: %s\n", $agent->vendor; # 'P' + printf "Series: %s\n", $agent->series; # "502i" + + # only available with

+ # e.g.) "DoCoMo/1.0/P503i/c10/serNMABH200331"; + printf "Serial: %s\n", $agent->serial_number; # "NMABH200331" + + # e.g.) "DoCoMo/2.0 N2001(c10;ser0123456789abcde;icc01234567890123456789)"; + printf "Serial: %s\n", $agent->serial_number; # "0123456789abcde" + printf "Card ID: %s\n", $agent->card_id; # "01234567890123456789" + + # e.g.) "DoCoMo/1.0/P502i (Google CHTML Proxy/1.0)" + printf "Comment: %s\n", $agent->comment; # "Google CHTML Proxy/1.0 + + # e.g.) "DoCoMo/1.0/D505i/c20/TB/W20H10" + printf "Status: %s\n", $agent->status; # "TB" + + # only available in eggy/M-stage + # e.g.) "DoCoMo/1.0/eggy/c300/s32/kPHS-K" + printf "Bandwidth: %dkbps\n", $agent->bandwidth; # 32 + + # e.g.) "DoCoMo/2.0 SO902i(c100;TB;W30H16)" + print "XHTML compiant!\n" if $agent->xhtml_compliant; # true + +=head1 DESCRIPTION + +HTTP::MobileAgent::DoCoMo is a subclass of HTTP::MobileAgent, which +implements NTT docomo i-mode user agents. + +=head1 METHODS + +See L for common methods. Here are +HTTP::MobileAgent::DoCoMo specific methods. + +=over 4 + +=item version + + $version = $agent->version; + +returns DoCoMo version number like "1.0". + +=item html_version + + $html_version = $agent->html_version; + +returns supported HTML version like '3.0'. retuns undef if unknown. + +=item model + + $model = $agent->model; + +returns name of the model like 'P502i'. + +=item cache_size + + $cache_size = $agent->cache_size; + +returns cache size as killobytes unit. returns 5 if unknown. + +=item is_foma + + if ($agent->is_foma) { } + +retuns whether it's FOMA or not. + +=item vendor + + $vendor = $agent->vendor; + +returns vender code like 'SO' for Sony. returns undef if unknown. + +=item series + + $series = $agent->series; + +returns series name like '502i'. returns undef if unknown. + +=item serial_number + + $serial_number = $agent->serial_number; + +returns hardware unique serial number (15 digit in FOMA, 11 digit +otherwise alphanumeric). Only available with Eform utnE +attribute. returns undef otherwise. + +=item card_id + + $card_id = $agent->card_id; + +returns FOMA Card ID (20 digit alphanumeric). Only available in FOMA +with Eform utnE attribute. returns undef otherwise. + +=item comment + + $comment = $agent->comment; + +returns comment on user agent string like 'Google Proxy'. returns +undef otherwise. + +=item bandwidth + + $bandwidth = $agent->bandwidth; + +returns bandwidth like 32 as killobytes unit. Only vailable in eggy, +returns undef otherwise. + +=item status + + $status = $agent->status; + +returns status like "TB", "TC", "TD" or "TJ", which means: + + TB | Browsers + TC | Browsers with image off (only Available in HTML 5.0) + TD | Fetching JAR + TJ | i-Appli + +=item xhtml_compliant + + if ($agent->xhtml_compliant) { } + +returns if the agent is XHTML compliant. + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +http://www.nttdocomo.co.jp/p_s/imode/spec/useragent.html + +http://www.nttdocomo.co.jp/p_s/imode/spec/ryouiki.html + +http://www.nttdocomo.co.jp/p_s/imode/tag/utn.html + +http://www.nttdocomo.co.jp/p_s/mstage/visual/contents/cnt_mpage.html + + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Vodafone.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Vodafone.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/Vodafone.pm (revision 24282) @@ -0,0 +1,313 @@ +package HTTP::MobileAgent::Vodafone; + +use strict; +use vars qw($VERSION); +$VERSION = 0.21; + +use base qw(HTTP::MobileAgent); + +__PACKAGE__->make_accessors( + qw(name version model type packet_compliant + serial_number vendor vendor_version java_info) +); + +sub is_j_phone { shift->is_vodafone } + +sub is_vodafone { 1 } + +sub is_softbank { shift->is_vodafone } + +sub carrier { 'V' } + +sub carrier_longname { 'Vodafone' } + +sub is_type_c { shift->{type} =~ /^C/ } +sub is_type_p { shift->{type} =~ /^P/ } +sub is_type_w { shift->{type} =~ /^W/ } +sub is_type_3gc { shift->{type} eq '3GC' } + +sub parse { + my $self = shift; + + return $self->_parse_3gc if($self->user_agent =~ /^Vodafone/); + return $self->_parse_softbank_3gc if($self->user_agent =~ /^SoftBank/); + return $self->_parse_motorola_3gc if($self->user_agent =~ /^MOT-/); + return $self->_parse_crawler if($self->user_agent =~ /^Nokia/); # ad hoc + + my($main, @rest) = split / /, _subtract_ua($self->user_agent); + + if (@rest) { + # J-PHONE/4.0/J-SH51/SNJSHA3029293 SH/0001aa Profile/MIDP-1.0 Configuration/CLDC-1.0 Ext-Profile/JSCL-1.1.0 + $self->{packet_compliant} = 1; + @{$self}{qw(name version model serial_number)} = split m!/!, $main; + if ($self->{serial_number}) { + $self->{serial_number} =~ s/^SN// or return $self->no_match; + } + + my $vendor = shift @rest; + @{$self}{qw(vendor vendor_version)} = split m!/!, $vendor; + + my %java_info = map split(m!/!), @rest; + $self->{java_info} = \%java_info; + } else { + # J-PHONE/2.0/J-DN02 + @{$self}{qw(name version model)} = split m!/!, $main; + $self->{name} = 'J-PHONE' if $self->{name} eq 'J-Phone'; # for J-Phone/5.0/J-SH03 (YahooSeeker) + $self->{vendor} = ($self->{model} =~ /J-([A-Z]+)/)[0] if $self->{model}; + } + + if ($self->version =~ /^2\./) { + $self->{type} = 'C2'; + } elsif ($self->version =~ /^3\./) { + if ($self->get_header('x-jphone-java')) { + $self->{type} = 'C4'; + } else { + $self->{type} = 'C3'; + } + } elsif ($self->version =~ /^4\./) { + my($jscl_ver) = ($self->{java_info}->{'Ext-Profile'} =~ /JSCL-(\d.+)/); + + if ($jscl_ver =~ /^1\.1\./) { + $self->{type} = 'P4'; + } elsif ($jscl_ver eq '1.2.1') { + $self->{type} = 'P5'; + } elsif ($jscl_ver eq '1.2.2') { + $self->{type} = 'P6'; + } else { + $self->{type} = 'P7'; + } + } elsif ($self->version =~ /^5\./) { + $self->{type} = 'W'; + } +} + +# for 3gc +sub _parse_3gc { + my $self = shift; + + # Vodafone/1.0/V802SE/SEJ001 Browser/SEMC-Browser/4.1 Profile/MIDP-2.0 Configuration/CLDC-1.1 + # Vodafone/1.0/V702NK/NKJ001 Series60/2.6 Profile/MIDP-2.0 Configuration/CLDC-1.1 + # SoftBank/1.0/910T/TJ001 Browser/NetFront/3.3 Profile/MIDP-2.0 Configuration/CLDC-1.1 + my($main, @rest) = split / /, $self->user_agent; + $self->{packet_compliant} = 1; + $self->{type} = '3GC'; + + @{$self}{qw(name version model _maker serial_number)} = split m!/!, $main; + if ($self->{serial_number}) { + $self->{serial_number} =~ s/^SN// or return $self->no_match; + } + + my($java_info) = $self->user_agent =~ /(Profile.*)$/; + my %java_info = map split(m!/!), split / /,$java_info; + $self->{java_info} = \%java_info; +} + +# for softbank 3gc +*_parse_softbank_3gc = \&_parse_3gc; + +# for motorola 3gc +sub _parse_motorola_3gc{ + my $self = shift; + my($main, @rest) = split / /, $self->user_agent; + + #MOT-V980/80.2B.04I MIB/2.2.1 Profile/MIDP-2.0 Configuration/CLDC-1.1 + + $self->{packet_compliant} = 1; + $self->{type} = '3GC'; + + @{$self}{qw(name)} = split m!/!, $main; + + shift @rest; + my %java_info = map split(m!/!), @rest; + $self->{java_info} = \%java_info; + + $self->{model} = 'V702MO' if $self->{name} eq 'MOT-V980'; + $self->{model} = 'V702sMO' if $self->{name} eq 'MOT-C980'; + $self->{model} ||= $self->get_header('x-jphone-msname'); +} + +# for crawler +sub _parse_crawler { + my $self = shift; + my($main, @rest) = split / /, _subtract_ua($self->user_agent); + + # Nokia6820/2.0 (4.83) Profile/MIDP-1.0 Configuration/CLDC-1.0 + @{$self}{qw(model)} = split m!/!, $main; + $self->{name} = 'Vodafone'; + $self->{type} = '3GC'; + + shift @rest; + my %java_info = map split(m!/!), @rest; + $self->{java_info} = \%java_info; +} + +sub _make_display { + my $self = shift; + my($width, $height) = split /\*/, $self->get_header('x-jphone-display'); + + my($color, $depth); + if (my $c_str = $self->get_header('x-jphone-color')) { + ($color, $depth) = $c_str =~ /^([CG])(\d+)$/; + } + + return HTTP::MobileAgent::Display->new( + width => $width, + height => $height, + color => $color eq 'C', + depth => $depth, + ); +} + +sub _subtract_ua { + my $user_agent = shift; + $user_agent =~ s/\s*$compatible\s*[^$]+\)//i; + return $user_agent; +} + +sub xhtml_compliant { + my $self = shift; + return ($self->is_type_w || $self->is_type_3gc) ? 1 : 0; +} + +sub user_id { + my $self = shift; + return $self->get_header( 'x-jphone-uid' ) unless $self->is_type_c; +} + +1; +__END__ + + +=head1 NAME + +HTTP::MobileAgent::Vodafone - Vodafone implementation + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + local $ENV{HTTP_USER_AGENT} = "J-PHONE/2.0/J-DN02"; + my $agent = HTTP::MobileAgent->new; + + printf "Name: %s\n", $agent->name; # "J-PHONE" + printf "Version: %s\n", $agent->version; # 2.0 + printf "Model: %s\n", $agent->model; # "J-DN02" + print "Packet is compliant.\n" if $agent->packet_compliant; # false + + # only availabe in Java compliant + # e.g.) "J-PHONE/4.0/J-SH51/SNXXXXXXXXX SH/0001a Profile/MIDP-1.0 Configuration/CLDC-1.0 Ext-Profile/JSCL-1.1.0" + printf "Serial: %s\n", $agent->serial_number; # XXXXXXXXXX + printf "Vendor: %s\n", $agent->vendor; # 'SH' + printf "Vender Version: %s\n", $agent->vendor_version; # "0001a" + + my $info = $self->java_info; # hash reference + print map { "$_: $info->{$_}\n" } keys %$info; + +=head1 DESCRIPTION + +HTTP::MobileAgent::Vodafone is a subclass of HTTP::MobileAgent, which +implements Vodafone(J-Phone) user agents. + +=head1 METHODS + +See L for common methods. Here are +HTTP::MobileAgent::Vodafone specific methods. + +=over 4 + +=item version + + $version = $agent->version; + +returns Vodafone version number like '1.0'. + +=item model + + $model = $agent->model; + +returns name of the model like 'J-DN02'. + +=item packet_compliant + + if ($agent->packet_compliant) { } + +returns whether the agent is packet connection complicant or not. + +=item serial_number + + $serial_number = $agent->serial_number; + +return terminal unique serial number. returns undef if user forbids to +send his/her serial number. + +=item vendor + + $vendor = $agent->vendor; + +returns vendor code like 'SH'. + +=item vendor_version + + $vendor_version = $agent->vendor_version; + +returns vendor version like '0001a'. returns undef if unknown, + +=item type + + if ($agent->type eq 'C2') { } + +returns the type, which is one of the following: C2 C3 C4 P4 P5 P6 P7 W 3GC + +=item is_type_c,is_type_p,is_type_w,is_type_3gc + + if ($agent->is_type_c) { } + +returns if the type is C, P or W. + +=item java_info + + $info = $agent->java_info; + +returns hash reference of Java profiles. Hash structure is something like: + + 'Profile' => 'MIDP-1.0', + 'Configuration' => 'CLDC-1.0', + 'Ext-Profile' => 'JSCL-1.1.0', + +returns undef if unknown. + +=item xhtml_compliant + + if ($agent->xhtml_compliant) { } + +returns if the agent is XHTML compliant. + +=back + +=head1 TODO + +=over 4 + +=item * + +Area information support on http://www.dp.j-phone.com/jsky/position.html + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +http://www.dp.j-phone.com/jsky/user.html + +http://www.dp.j-phone.com/jsky/position.html + + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/NonMobile.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/NonMobile.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/NonMobile.pm (revision 24282) @@ -0,0 +1,63 @@ +package HTTP::MobileAgent::NonMobile; + +use strict; +use vars qw($VERSION); +$VERSION = 0.02; +use base qw(HTTP::MobileAgent); + +__PACKAGE__->make_accessors( + qw(model device_id) +); + +sub parse { + my $self = shift; + my($name, $version) = split m!/!, $self->user_agent; + $self->{name} = $name; + $self->{version} = $version; + $self->{device_id} = ''; + $self->{model} = ''; +} + +sub is_non_mobile { 1 } + +sub carrier { 'N' } + +sub carrier_longname { 'NonMobile' } + +sub xhtml_compliant { 1 } + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent::NonMobile - Non-Mobile Agent implementation + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + local $ENV{HTTP_USER_AGENT} = "Mozilla/4.0"; + my $agent = HTTP::MobileAgent->new; + +=head1 DESCRIPTION + +HTTP::MobileAgent::NonMobile is a subclass of HTTP::MobileAgent, which +implements non-mobile or unimplemented user agents. + +=head1 METHODS + +See L for common methods. + +=head1 AUTHOR + +Tatsuhiko Miyagawa Emiyagawa@bulknews.netE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/JPhone.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/JPhone.pm (revision 24282) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/MobileAgent/JPhone.pm (revision 24282) @@ -0,0 +1,51 @@ +package HTTP::MobileAgent::JPhone; + +use strict; +use vars qw($VERSION); +$VERSION = 0.18; + +use base qw(HTTP::MobileAgent::Vodafone); + +1; +__END__ + +=head1 NAME + +HTTP::MobileAgent::JPhone - J-Phone implementation + +=head1 SYNOPSIS + + use HTTP::MobileAgent; + + local $ENV{HTTP_USER_AGENT} = "J-PHONE/2.0/J-DN02"; + my $agent = HTTP::MobileAgent->new; + + printf "Name: %s\n", $agent->name; # "J-PHONE" + printf "Version: %s\n", $agent->version; # 2.0 + printf "Model: %s\n", $agent->model; # "J-DN02" + print "Packet is compliant.\n" if $agent->packet_compliant; # false + + # only availabe in Java compliant + # e.g.) "J-PHONE/4.0/J-SH51/SNXXXXXXXXX SH/0001a Profile/MIDP-1.0 Configuration/CLDC-1.0 Ext-Profile/JSCL-1.1.0" + printf "Serial: %s\n", $agent->serial_number; # XXXXXXXXXX + printf "Vendor: %s\n", $agent->vendor; # 'SH' + printf "Vender Version: %s\n", $agent->vendor_version; # "0001a" + + my $info = $self->java_info; # hash reference + print map { "$_: $info->{$_}\n" } keys %$info; + +=head1 DESCRIPTION + +HTTP::MobileAgent::JPhone is a subclass of HTTP::MobileAgent::Vodafone. + +=head1 METHODS + +See L for methods. + + +=head1 SEE ALSO + +L + + +=cut Index: lang/perl/MENTA/branches/henta/extlib/HTTP/Server/Simple.pm =================================================================== --- lang/perl/MENTA/branches/henta/extlib/HTTP/Server/Simple.pm (revision 23452) +++ lang/perl/MENTA/branches/henta/extlib/HTTP/Server/Simple.pm (revision 23452) @@ -0,0 +1,762 @@ +use strict; +use warnings; + +package HTTP::Server::Simple; +use FileHandle; +use Socket; +use Carp; +use URI::Escape; + +use vars qw($VERSION $bad_request_doc); +$VERSION = '0.35'; + + +=head1 NAME + +HTTP::Server::Simple - Lightweight HTTP server + + +=head1 SYNOPSIS + + use warnings; + use strict; + + use HTTP::Server::Simple; + + my $server = HTTP::Server::Simple->new(); + $server->run(); + +However, normally you will sub-class the HTTP::Server::Simple::CGI +module (see L); + + package Your::Web::Server; + use base qw(HTTP::Server::Simple::CGI); + + sub handle_request { + my ($self, $cgi) = @_; + + #... do something, print output to default + # selected filehandle... + + } + + 1; + +=head1 DESCRIPTION + +This is a simple standalone HTTP server. By default, it doesn't thread +or fork. + +It does, however, act as a simple frontend which can be used +to build a standalone web-based application or turn a CGI into one. + +(It's possible to use Net::Server to get threading, forking, +preforking and so on. Autrijus Tang wrote the functionality and owes docs for that ;) + +By default, the server traps a few signals: + +=over + +=item HUP + +When you C the server, it lets the current request finish being +processed, then uses the C method to re-exec itself. Please note that +in order to provide restart-on-SIGHUP, HTTP::Server::Simple sets a SIGHUP +handler during initialisation. If your request handling code forks you need to +make sure you reset this or unexpected things will happen if somebody sends a +HUP to all running processes spawned by your app (e.g. by "kill -HUP

セッションID
カウンタ
セッション状態管理クラス
セッション保存クラス

自分専用カウンターです

MENTA デモサイト

MENTA

OpenID でキャンセルしましたね

OpenID でログインするデモ

MENTA

諸情報

環境変数

MENTA の設定

MENTA標準添付モジュール

Perl標準添付モジュール(perl )

わたしのホームページ

Web Application Framework - MENTA

MENTA ってなに?

現在利用できる項目

MENTA

ダウンロードする

サーバーにアップロードする

ディレクトリ構造

実際につかってみる

Hello World してみる

カウンターをつけてみる

リリース版のダウンロード

開発版スナップショット

MENTA マニュアル

LICENSE

開発者