1 39.95387 22.14000 137:$game_thread->join(); 1 0.08773 0.08000 134:my $game_thread = threads->new(\&game); 1 0.08245 0.08000 131:my $netin_thread = threads->new(\&net_in ); 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, 1 0.00001 0.00000 51:our $EventQueue = Thread::Queue->new; ================ 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: 0 0.00000 0.00000 45: my @pkgattrs = _modify_attrs($svref, 0 0.00000 0.00000 46: 0 0.00000 0.00000 46: @badattrs = $pkgmeth->($home_stash, $svref, 0 0.00000 0.00000 46:#special globs 0 0.00000 0.00000 47: 0 0.00000 0.00000 47: if (!@badattrs && @pkgattrs) { 0 0.00000 0.00000 47:#to move in another file 0 0.00000 0.00000 48: 0 0.00000 0.00000 48: 0 0.00000 0.00000 48: return unless _warn_reserved; 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:#thread to communicate with game loop. 0 0.00000 0.00000 51: 0 0.00000 0.00000 51: for my $attr (@pkgattrs) { 0 0.00000 0.00000 52: 0 0.00000 0.00000 52: 0 0.00000 0.00000 52: $attr =~ s/\(.+\z//s; 0 0.00000 0.00000 53: 0 0.00000 0.00000 53: } 0 0.00000 0.00000 53:#the STOP flag. 0 0.00000 0.00000 54: 0 0.00000 0.00000 54: my $s = ((@pkgattrs == 1) ? '' : 's'); 0 0.00000 0.00000 55: 0 0.00000 0.00000 55: 0 0.00000 0.00000 55: carp "$svtype package attribute$s " . 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:#the global game loop 0 0.00000 0.00000 57: 0 0.00000 0.00000 57: join(' : ' , @pkgattrs); 0 0.00000 0.00000 57:sub game { 0 0.00000 0.00000 58: 0 0.00000 0.00000 58: } 0 0.00000 0.00000 58: #game type 0 0.00000 0.00000 59: 0 0.00000 0.00000 59: my $TYPE = 14; 0 0.00000 0.00000 59: } 0 0.00000 0.00000 60: 0 0.00000 0.00000 60: 0 0.00000 0.00000 60: } 0 0.00000 0.00000 61: 0 0.00000 0.00000 61: else { 0 0.00000 0.00000 61: #the UI window 0 0.00000 0.00000 62: 0 0.00000 0.00000 62: our $WINDOW; 0 0.00000 0.00000 63: 0 0.00000 0.00000 63: 0 0.00000 0.00000 63: } 0 0.00000 0.00000 64: 0 0.00000 0.00000 64: #init the game 0 0.00000 0.00000 65: 0 0.00000 0.00000 65: croak "Invalid $svtype attribute" . 0 0.00000 0.00000 65: print "Initialising screen\n"; 0 0.00000 0.00000 66: 0 0.00000 0.00000 66: 0 0.00000 0.00000 66: (( @badattrs == 1 ) ? '' : 's') . 0 0.00000 0.00000 67: ": " . 0 0.00000 0.00000 67: #first define the screen 0 0.00000 0.00000 67:sub new { 0 0.00000 0.00000 68: join(' : ', @badattrs); 0 0.00000 0.00000 68: our $screen = SDL::App->new( 0 0.00000 0.00000 69: } 0 0.00000 0.00000 69: -width => 640, 0 0.00000 0.00000 70: -height => 480, 0 0.00000 0.00000 70:} 0 0.00000 0.00000 71: 0 0.00000 0.00000 71: -depth => 16, 0 0.00000 0.00000 71:} 0 0.00000 0.00000 72: 0 0.00000 0.00000 72: -fullscreen =>0, 0 0.00000 0.00000 72:sub get ($) { 0 0.00000 0.00000 73: @_ == 1 && ref $_[0] or 0 0.00000 0.00000 73: ); 0 0.00000 0.00000 73:sub dequeue { 0 0.00000 0.00000 74: 0 0.00000 0.00000 74: my $q = shift; 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: #hide the cursor 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: SDL::ShowCursor (0); 0 0.00000 0.00000 77: 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: $stash = caller unless defined $stash; 0 0.00000 0.00000 78: return shift @$q; 0 0.00000 0.00000 78: #load game images 0 0.00000 0.00000 79: my $pkgmeth; 0 0.00000 0.00000 79: our $imgs = prone_image_load(); 0 0.00000 0.00000 79:} 0 0.00000 0.00000 80: 0 0.00000 0.00000 80: 0 0.00000 0.00000 80: $pkgmeth = UNIVERSAL::can($stash, 0 0.00000 0.00000 81: #load game fonts 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: our $fonts = prone_font_load(); 0 0.00000 0.00000 82: my $q = shift; 0 0.00000 0.00000 82: return $pkgmeth ? 0 0.00000 0.00000 83: 0 0.00000 0.00000 83: lock(@$q); 0 0.00000 0.00000 83: (_fetch_attrs($svref), $pkgmeth->($stash, 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: #select between game types 20 for EXIT.( to 0 0.00000 0.00000 85: ; 0 0.00000 0.00000 85:} 0 0.00000 0.00000 86: 0 0.00000 0.00000 86: while( $TYPE != 20 ) { 0 0.00000 0.00000 86:} 0 0.00000 0.00000 87: 0 0.00000 0.00000 87: #title screen 0 0.00000 0.00000 87:sub enqueue { 0 0.00000 0.00000 88: if( $TYPE == 4 ) { 0 0.00000 0.00000 88: my $q = shift; 0 0.00000 0.00000 88:sub require_version { goto 0 0.00000 0.00000 89: 0 0.00000 0.00000 89: lock(@$q); 0 0.00000 0.00000 89: #title_screen(); 0 0.00000 0.00000 90: push @$q, @_ and cond_signal @$q; 0 0.00000 0.00000 90: $ProneClient::STOP = 0; 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: #network game 0 0.00000 0.00000 93: if( $TYPE == 14 ) { 0 0.00000 0.00000 93:sub pending { 0 0.00000 0.00000 94: my $q = shift; 0 0.00000 0.00000 94: print "Starting netplay\n"; 0 0.00000 0.00000 95: prone_netplay(); 0 0.00000 0.00000 95: lock(@$q); 0 0.00000 0.00000 96: $TYPE=4; 0 0.00000 0.00000 96: return scalar(@$q); 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: } 0 0.00000 0.00000 99:1; 0 0.00000 0.00000 100: 0 0.00000 0.00000 100: return 0; 0 0.00000 0.00000 101: 0 0.00000 0.00000 101:} 0 0.00000 0.00000 102: 0 0.00000 0.00000 103:#the function gather network packets. 0 0.00000 0.00000 104:sub net_in { 0 0.00000 0.00000 105: my $host = shift || 'painkiller'; 0 0.00000 0.00000 106: my $port = shift || 12345; 0 0.00000 0.00000 107: my $buf ; 0 0.00000 0.00000 108: my $sock = new IO::Socket::INET( 0 0.00000 0.00000 109: PeerAddr => $host, 0 0.00000 0.00000 110: PeerPort => $port, 0 0.00000 0.00000 111: Proto => 'tcp'); 0 0.00000 0.00000 112: $sock or die "no socket :$!"; 0 0.00000 0.00000 113: $sock->autoflush(1); 0 0.00000 0.00000 114: 0 0.00000 0.00000 115: while (defined($buf = <$sock>) and 0 0.00000 0.00000 116: #temp , to be removed when server won't 0 0.00000 0.00000 117:# print STDERR "RECEIVED : $buf \n"; 0 0.00000 0.00000 118: $ProneClient::EventQueue->enqueue($buf) if 0 0.00000 0.00000 119: } 0 0.00000 0.00000 120: 0 0.00000 0.00000 121: return 0; 0 0.00000 0.00000 122:} 0 0.00000 0.00000 123: 0 0.00000 0.00000 124: 0 0.00000 0.00000 125:#main 0 0.00000 0.00000 126: 0 0.00000 0.00000 127:#init 0 0.00000 0.00000 129: 0 0.00000 0.00000 130:#start network collecting. 0 0.00000 0.00000 132: 0 0.00000 0.00000 133:#launch the game 0 0.00000 0.00000 135: 0 0.00000 0.00000 136:#wait for game to end. 0 0.00000 0.00000 138: 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 54: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 128: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