1 30.24542 21.80000 144:$game_thread->join(); 1 0.08621 0.08000 141:my $game_thread = threads->new(\&game); 1 0.08393 0.08000 138:my $netin_thread = threads->new(\&net_in ); 1 0.00002 0.00000 58:our $EventQueue = Thread::Queue->new; 1 0.00002 0.00000 62: @badattrs = _modify_attrs($svref, @attrs); 1 0.00002 0.00000 64: if (@badattrs) { 1 0.00002 0.00000 70: return bless \@q, $class; 1 0.00001 0.00000 41: $pkgmeth = UNIVERSAL::can($home_stash, ================ SmallProf version 2.02 ================ ================ SmallProf version 2.02 ================ ================ SmallProf version 2.02 ================ ================ SmallProf version 2.02 ================ ================ SmallProf version 2.02 ================ ================ SmallProf version 2.02 ================ Profile of main.pl Page 5 Profile of main.pl Page 6 Profile of main.pl Page 7 Profile of /usr/lib64/perl5/5.8.8/attributes.pm Page 3 Profile of /usr/lib64/perl5/5.8.8/attributes.pm Page 4 Profile of /usr/lib64/perl5/5.8.8/Thread/Queue.pm Page 1 Profile of /usr/lib64/perl5/5.8.8/Thread/Queue.pm Page 2 ================ SmallProf version 2.02 ================ 0 0.00000 0.00000 1:#!/usr/bin/perl -w -I ./modules -I 0 0.00000 0.00000 1:package Thread::Queue; 0 0.00000 0.00000 1:package attributes; 0 0.00000 0.00000 2: 0 0.00000 0.00000 2: 0 0.00000 0.00000 2:package ProneClient; 0 0.00000 0.00000 3: 0 0.00000 0.00000 3:our $VERSION = 0.06; 0 0.00000 0.00000 3:use threads::shared; 0 0.00000 0.00000 4: 0 0.00000 0.00000 4:#include external perl modules. 0 0.00000 0.00000 4:use strict; 0 0.00000 0.00000 5: 0 0.00000 0.00000 5:@EXPORT_OK = qw(get reftype); 0 0.00000 0.00000 5:use SDL; 0 0.00000 0.00000 6:@EXPORT = (); 0 0.00000 0.00000 6:our $VERSION = '2.00'; 0 0.00000 0.00000 6:use SDL::Rect; 0 0.00000 0.00000 7: 0 0.00000 0.00000 7:%EXPORT_TAGS = (ALL => [@EXPORT, 0 0.00000 0.00000 7:use SDL::Surface; 0 0.00000 0.00000 8: 0 0.00000 0.00000 8:=head1 NAME 0 0.00000 0.00000 8:use SDL::App; 0 0.00000 0.00000 9: 0 0.00000 0.00000 9:use SDL::Timer; 0 0.00000 0.00000 9:use strict; 0 0.00000 0.00000 10: 0 0.00000 0.00000 10: 0 0.00000 0.00000 10:use SDL::TTFont; 0 0.00000 0.00000 11: 0 0.00000 0.00000 11:sub croak { 0 0.00000 0.00000 11:use SDL::Tool::Graphic; 0 0.00000 0.00000 12: 0 0.00000 0.00000 12: require Carp; 0 0.00000 0.00000 12:use SDL::Mixer; 0 0.00000 0.00000 13: 0 0.00000 0.00000 13: goto &Carp::croak; 0 0.00000 0.00000 13:use SDL::Music; 0 0.00000 0.00000 14: 0 0.00000 0.00000 14:use threads; 0 0.00000 0.00000 14:} 0 0.00000 0.00000 15: 0 0.00000 0.00000 15: 0 0.00000 0.00000 15:use threads::shared; 0 0.00000 0.00000 16: 0 0.00000 0.00000 16:sub carp { 0 0.00000 0.00000 16:use Thread::Queue; 0 0.00000 0.00000 17: 0 0.00000 0.00000 17: require Carp; 0 0.00000 0.00000 17:use IO::Socket; 0 0.00000 0.00000 18: 0 0.00000 0.00000 18: goto &Carp::carp; 0 0.00000 0.00000 18:use Data::Dumper; 0 0.00000 0.00000 19: 0 0.00000 0.00000 19:use Config::IniFiles; 0 0.00000 0.00000 19:} 0 0.00000 0.00000 20: 0 0.00000 0.00000 20: 0 0.00000 0.00000 20:use Games::RolePlay::MapGen; 0 0.00000 0.00000 21: 0 0.00000 0.00000 21:## forward declaration(s) rather than 0 0.00000 0.00000 21:use Time::HiRes qw ( time alarm sleep 0 0.00000 0.00000 22: 0 0.00000 0.00000 22:#sub reftype ($) ; 0 0.00000 0.00000 22:use XML::Simple; 0 0.00000 0.00000 23: 0 0.00000 0.00000 23: 0 0.00000 0.00000 23:#sub _fetch_attrs ($) ; 0 0.00000 0.00000 24: 0 0.00000 0.00000 24:#be strict ! 0 0.00000 0.00000 24:#sub _guess_stash ($) ; 0 0.00000 0.00000 25: 0 0.00000 0.00000 25:#sub _modify_attrs ; 0 0.00000 0.00000 25:use strict; 0 0.00000 0.00000 26: 0 0.00000 0.00000 26:#include internal perl modules. 0 0.00000 0.00000 26:#sub _warn_reserved () ; 0 0.00000 0.00000 27: 0 0.00000 0.00000 27:# 0 0.00000 0.00000 27:use input; 0 0.00000 0.00000 28: 0 0.00000 0.00000 28:# The extra trips through newATTRSUB in the 0 0.00000 0.00000 28:use graphic; 0 0.00000 0.00000 29: 0 0.00000 0.00000 29:# from avoiding the BEGIN block. Just do the 0 0.00000 0.00000 29:use game; 0 0.00000 0.00000 30: 0 0.00000 0.00000 30:BEGIN { bootstrap attributes } 0 0.00000 0.00000 30:use network; 0 0.00000 0.00000 31: 0 0.00000 0.00000 31: 0 0.00000 0.00000 31:use events; 0 0.00000 0.00000 32: 0 0.00000 0.00000 32:sub import { 0 0.00000 0.00000 32:use maps; 0 0.00000 0.00000 33: 0 0.00000 0.00000 33:use config; 0 0.00000 0.00000 34: 0 0.00000 0.00000 34: 0 0.00000 0.00000 34: require Exporter; 0 0.00000 0.00000 35: 0 0.00000 0.00000 35: goto &Exporter::import; 0 0.00000 0.00000 35:#include Classes 0 0.00000 0.00000 36: 0 0.00000 0.00000 36: }; 0 0.00000 0.00000 36:use Object; 0 0.00000 0.00000 37: 0 0.00000 0.00000 37:use Char; 0 0.00000 0.00000 38: 0 0.00000 0.00000 38: 0 0.00000 0.00000 38:use Player; 0 0.00000 0.00000 39: 0 0.00000 0.00000 39:use Window; 0 0.00000 0.00000 40: 0 0.00000 0.00000 40:use Widget; 0 0.00000 0.00000 41: 0 0.00000 0.00000 41:use WindowLogin; 0 0.00000 0.00000 42: 0 0.00000 0.00000 42: if defined $home_stash && $home_stash ne ''; 0 0.00000 0.00000 42:use WindowConsole; 0 0.00000 0.00000 43: 0 0.00000 0.00000 43:use WindowEditor; 0 0.00000 0.00000 44: 0 0.00000 0.00000 44: 0 0.00000 0.00000 45: 0 0.00000 0.00000 45: my @pkgattrs = _modify_attrs($svref, 0 0.00000 0.00000 45:#use Devel::AutoProfiler; 0 0.00000 0.00000 46: 0 0.00000 0.00000 46: 0 0.00000 0.00000 46: @badattrs = $pkgmeth->($home_stash, $svref, 0 0.00000 0.00000 47: 0 0.00000 0.00000 47: if (!@badattrs && @pkgattrs) { 0 0.00000 0.00000 47:#special globs 0 0.00000 0.00000 48: 0 0.00000 0.00000 48: return unless _warn_reserved; 0 0.00000 0.00000 48:#to move in another file 0 0.00000 0.00000 49: 0 0.00000 0.00000 49: 0 0.00000 0.00000 49: @pkgattrs = grep { 0 0.00000 0.00000 50: 0 0.00000 0.00000 50: if (@pkgattrs) { 0 0.00000 0.00000 50:#use Devel::Profiler; 0 0.00000 0.00000 51: 0 0.00000 0.00000 51: for my $attr (@pkgattrs) { 0 0.00000 0.00000 51:# 0 0.00000 0.00000 52: 0 0.00000 0.00000 52: $attr =~ s/\(.+\z//s; 0 0.00000 0.00000 52:# package_filter => sub { 0 0.00000 0.00000 53: 0 0.00000 0.00000 53: } 0 0.00000 0.00000 53:# my $pkg = shift; 0 0.00000 0.00000 54: 0 0.00000 0.00000 54: my $s = ((@pkgattrs == 1) ? '' : 's'); 0 0.00000 0.00000 54:# return 0 if $pkg 0 0.00000 0.00000 55: 0 0.00000 0.00000 55: carp "$svtype package attribute$s " . 0 0.00000 0.00000 55:# return 1; 0 0.00000 0.00000 56: 0 0.00000 0.00000 56: "may clash with future reserved word$s: 0 0.00000 0.00000 56:# }; 0 0.00000 0.00000 57: 0 0.00000 0.00000 57: join(' : ' , @pkgattrs); 0 0.00000 0.00000 57:#thread to communicate with game loop. 0 0.00000 0.00000 58: 0 0.00000 0.00000 58: } 0 0.00000 0.00000 59: 0 0.00000 0.00000 59: 0 0.00000 0.00000 59: } 0 0.00000 0.00000 60: 0 0.00000 0.00000 60: } 0 0.00000 0.00000 60:#the STOP flag. 0 0.00000 0.00000 61: 0 0.00000 0.00000 61: else { 0 0.00000 0.00000 62: 0 0.00000 0.00000 62: 0 0.00000 0.00000 63: 0 0.00000 0.00000 63: } 0 0.00000 0.00000 63:#the global game loop 0 0.00000 0.00000 64: 0 0.00000 0.00000 64:sub game { 0 0.00000 0.00000 65: 0 0.00000 0.00000 65: #game type 0 0.00000 0.00000 65: croak "Invalid $svtype attribute" . 0 0.00000 0.00000 66: 0 0.00000 0.00000 66: (( @badattrs == 1 ) ? '' : 's') . 0 0.00000 0.00000 66: my $TYPE = 14; 0 0.00000 0.00000 67: 0 0.00000 0.00000 67: ": " . 0 0.00000 0.00000 67:sub new { 0 0.00000 0.00000 68: join(' : ', @badattrs); 0 0.00000 0.00000 68: #the UI window 0 0.00000 0.00000 69: } 0 0.00000 0.00000 69: our $WINDOW; 0 0.00000 0.00000 70: 0 0.00000 0.00000 70:} 0 0.00000 0.00000 71: 0 0.00000 0.00000 71: #init the game 0 0.00000 0.00000 71:} 0 0.00000 0.00000 72: 0 0.00000 0.00000 72: print "Initialising screen\n"; 0 0.00000 0.00000 72:sub get ($) { 0 0.00000 0.00000 73: 0 0.00000 0.00000 73: @_ == 1 && ref $_[0] or 0 0.00000 0.00000 73:sub dequeue { 0 0.00000 0.00000 74: my $q = shift; 0 0.00000 0.00000 74: #first define the screen 0 0.00000 0.00000 74: croak 'Usage: '.__PACKAGE__.'::get $ref'; 0 0.00000 0.00000 75: lock(@$q); 0 0.00000 0.00000 75: my $svref = shift; 0 0.00000 0.00000 75: our $screen = SDL::App->new( 0 0.00000 0.00000 76: cond_wait @$q until @$q; 0 0.00000 0.00000 76: my $svtype = uc reftype $svref; 0 0.00000 0.00000 76: -width => 640, 0 0.00000 0.00000 77: -height => 480, 0 0.00000 0.00000 77: cond_signal @$q if @$q > 1; 0 0.00000 0.00000 77: my $stash = _guess_stash $svref; 0 0.00000 0.00000 78: -depth => 16, 0 0.00000 0.00000 78: $stash = caller unless defined $stash; 0 0.00000 0.00000 78: return shift @$q; 0 0.00000 0.00000 79: -fullscreen =>0, 0 0.00000 0.00000 79: my $pkgmeth; 0 0.00000 0.00000 79:} 0 0.00000 0.00000 80: 0 0.00000 0.00000 80: $pkgmeth = UNIVERSAL::can($stash, 0 0.00000 0.00000 80: ); 0 0.00000 0.00000 81: 0 0.00000 0.00000 81: if defined $stash && $stash ne ''; 0 0.00000 0.00000 81:sub dequeue_nb { 0 0.00000 0.00000 82: my $q = shift; 0 0.00000 0.00000 82: return $pkgmeth ? 0 0.00000 0.00000 82: #hide the cursor 0 0.00000 0.00000 83: lock(@$q); 0 0.00000 0.00000 83: (_fetch_attrs($svref), $pkgmeth->($stash, 0 0.00000 0.00000 83: SDL::ShowCursor (0); 0 0.00000 0.00000 84: 0 0.00000 0.00000 84: return shift @$q; 0 0.00000 0.00000 84: (_fetch_attrs($svref)) 0 0.00000 0.00000 85: #load game images 0 0.00000 0.00000 85: ; 0 0.00000 0.00000 85:} 0 0.00000 0.00000 86: 0 0.00000 0.00000 86: our $imgs = prone_image_load(); 0 0.00000 0.00000 86:} 0 0.00000 0.00000 87: 0 0.00000 0.00000 87: 0 0.00000 0.00000 87:sub enqueue { 0 0.00000 0.00000 88: my $q = shift; 0 0.00000 0.00000 88: #load game fonts 0 0.00000 0.00000 88:sub require_version { goto 0 0.00000 0.00000 89: 0 0.00000 0.00000 89: our $fonts = prone_font_load(); 0 0.00000 0.00000 89: lock(@$q); 0 0.00000 0.00000 90: 0 0.00000 0.00000 90: push @$q, @_ and cond_signal @$q; 0 0.00000 0.00000 90:1; 0 0.00000 0.00000 91: 0 0.00000 0.00000 91:__END__ 0 0.00000 0.00000 91:} 0 0.00000 0.00000 92: 0 0.00000 0.00000 92: #select between game types 20 for EXIT.( to 0 0.00000 0.00000 93: while( $TYPE != 20 ) { 0 0.00000 0.00000 93:sub pending { 0 0.00000 0.00000 94: my $q = shift; 0 0.00000 0.00000 94: #title screen 0 0.00000 0.00000 95: if( $TYPE == 4 ) { 0 0.00000 0.00000 95: lock(@$q); 0 0.00000 0.00000 96: return scalar(@$q); 0 0.00000 0.00000 96: #title_screen(); 0 0.00000 0.00000 97: $ProneClient::STOP = 0; 0 0.00000 0.00000 97:} 0 0.00000 0.00000 98: 0 0.00000 0.00000 98: } 0 0.00000 0.00000 99: #network game 0 0.00000 0.00000 99:1; 0 0.00000 0.00000 100: 0 0.00000 0.00000 100: if( $TYPE == 14 ) { 0 0.00000 0.00000 101: 0 0.00000 0.00000 101: print "Starting netplay\n"; 0 0.00000 0.00000 102: prone_netplay(); 0 0.00000 0.00000 103: $TYPE=4; 0 0.00000 0.00000 104: $ProneClient::STOP = 0; 0 0.00000 0.00000 105: } 0 0.00000 0.00000 106: } 0 0.00000 0.00000 107: return 0; 0 0.00000 0.00000 108:} 0 0.00000 0.00000 109: 0 0.00000 0.00000 110:#the function gather network packets. 0 0.00000 0.00000 111:sub net_in { 0 0.00000 0.00000 112: my $host = shift || 'painkiller'; 0 0.00000 0.00000 113: my $port = shift || 12345; 0 0.00000 0.00000 114: my $buf ; 0 0.00000 0.00000 115: my $sock = new IO::Socket::INET( 0 0.00000 0.00000 116: PeerAddr => $host, 0 0.00000 0.00000 117: PeerPort => $port, 0 0.00000 0.00000 118: Proto => 'tcp'); 0 0.00000 0.00000 119: $sock or die "no socket :$!"; 0 0.00000 0.00000 120: $sock->autoflush(1); 0 0.00000 0.00000 121: 0 0.00000 0.00000 122: while (defined($buf = <$sock>) and 0 0.00000 0.00000 123: #temp , to be removed when server won't 0 0.00000 0.00000 124:# print STDERR "RECEIVED : $buf \n"; 0 0.00000 0.00000 125: $ProneClient::EventQueue->enqueue($buf) if 0 0.00000 0.00000 126: } 0 0.00000 0.00000 127: 0 0.00000 0.00000 128: return 0; 0 0.00000 0.00000 129:} 0 0.00000 0.00000 130: 0 0.00000 0.00000 131: 0 0.00000 0.00000 132:#main 0 0.00000 0.00000 133: 0 0.00000 0.00000 134:#init 0 0.00000 0.00000 136: 0 0.00000 0.00000 137:#start network collecting. 0 0.00000 0.00000 139: 0 0.00000 0.00000 140:#launch the game 0 0.00000 0.00000 142: 0 0.00000 0.00000 143:#wait for game to end. 0 0.00000 0.00000 145: 1 0.00000 0.00000 33: @_ > 2 && ref $_[2] or do { 1 0.00000 0.00000 37: my (undef,$home_stash,$svref,@attrs) = 1 0.00000 0.00000 39: my $svtype = uc reftype($svref); 1 0.00000 0.00000 40: my $pkgmeth; 1 0.00000 0.00000 43: my @badattrs; 1 0.00000 0.00000 44: if ($pkgmeth) { 1 0.00000 0.00000 61:our $STOP = 0; 1 0.00000 0.00000 68: my $class = shift; 1 0.00000 0.00000 69: my @q : shared = @_; 1 0.00000 0.00000 135:our @history : shared; ================================================================= ================================================================= ================================================================= ================================================================= ================================================================= ================================================================= ================================================================= count wall tm cpu time line count wall tm cpu time line count wall tm cpu time line count wall tm cpu time line count wall tm cpu time line count wall tm cpu time line count wall tm cpu time line