1#+############################################################################## 2# # 3# File: Net/STOMP/Client/Frame.pm # 4# # 5# Description: Frame support for Net::STOMP::Client # 6# # 7#-############################################################################## 8 9# 10# module definition 11# 12 13package Net::STOMP::Client::Frame; 14use 5.005; # need the four-argument form of substr() 15use strict; 16use warnings; 17our $VERSION = "2.3"; 18our $REVISION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/); 19 20# 21# used modules 22# 23 24use Encode qw(); 25use No::Worries::Die qw(dief); 26use No::Worries::Export qw(export_control); 27use No::Worries::Log qw(log_debug); 28use Params::Validate qw(validate validate_pos :types); 29 30# 31# constants 32# 33 34use constant I_COMMAND => 0; 35use constant I_HEADERS => 1; 36use constant I_BODY => 2; # stored as reference 37 38# 39# global variables 40# 41 42our( 43 # public 44 $DebugBodyLength, # the maximum length of body that will be debugged 45 $StrictEncode, # true if encoding/decoding operations should be strict 46 # private 47 $_HeaderNameRE, # regular expression matching a header name (STOMP 1.0) 48 %_EncMap1, # map to \-encode some chars in the header (STOMP 1.1) 49 %_DecMap1, # map to \-decode some chars in the header (STOMP 1.1) 50 $_EncSet1, # set of chars to encode in the header (STOMP 1.1) 51 %_EncMap2, # map to \-encode some chars in the header (STOMP >= 1.2) 52 %_DecMap2, # map to \-decode some chars in the header (STOMP >= 1.2) 53 $_EncSet2, # set of chars to encode in the header (STOMP >= 1.2) 54); 55 56# public 57$DebugBodyLength = 256; 58$StrictEncode = undef; 59 60# private 61$_HeaderNameRE = q/[_a-zA-Z0-9\-\.]+/; 62%_EncMap1 = %_EncMap2 = ( 63 "\r" => "\\r", 64 "\n" => "\\n", 65 ":" => "\\c", 66 "\\" => "\\\\", 67); 68delete($_EncMap1{"\r"}); # \r encoding is only for STOMP >= 1.2 69%_DecMap1 = reverse(%_EncMap1); 70$_EncSet1 = "[".join("", map(sprintf("\\x%02x", ord($_)), keys(%_EncMap1)))."]"; 71%_DecMap2 = reverse(%_EncMap2); 72$_EncSet2 = "[".join("", map(sprintf("\\x%02x", ord($_)), keys(%_EncMap2)))."]"; 73 74#+++############################################################################ 75# # 76# helpers # 77# # 78#---############################################################################ 79 80# 81# helper to guess the encoding to use from the content type header 82# 83 84sub _encoding ($) { 85 my($type) = @_; 86 87 if ($type) { 88 if ($type =~ /^text\/[\w\-]+$/) { 89 return("UTF-8"); 90 } elsif (";$type;" =~ /\;\s*charset=\"?([\w\-]+)\"?\s*\;/) { 91 return($1); 92 } else { 93 return(undef); 94 } 95 } else { 96 return(undef); 97 } 98} 99 100# 101# debugging helpers 102# 103 104sub _debug_command ($$) { 105 my($what, $command) = @_; 106 107 log_debug("%s %s frame", $what, $command); 108} 109 110sub _debug_header ($) { 111 my($header) = @_; 112 my($offset, $length, $line, $char); 113 114 $length = length($header); 115 $offset = 0; 116 while ($offset < $length) { 117 $line = ""; 118 while (1) { 119 $char = ord(substr($header, $offset, 1)); 120 $offset++; 121 if ($char == 0x0a) { 122 last; 123 } elsif (0x20 <= $char and $char <= 0x7e and $char != 0x25) { 124 $line .= sprintf("%c", $char); 125 } else { 126 $line .= sprintf("%%%02x", $char); 127 } 128 last if $offset == $length; 129 } 130 log_debug(" H %s", $line); 131 } 132} 133 134sub _debug_body ($) { 135 my($body) = @_; 136 my($offset, $length, $line, $ascii, $char); 137 138 $length = length($body); 139 if ($DebugBodyLength and $length > $DebugBodyLength) { 140 substr($body, $DebugBodyLength, $length - $DebugBodyLength, ""); 141 $length = $DebugBodyLength; 142 } 143 $offset = 0; 144 while ($length > 0) { 145 $line = sprintf("%04x", $offset); 146 $ascii = ""; 147 foreach my $index (0 .. 15) { 148 if (($index & 3) == 0) { 149 $line .= " "; 150 $ascii .= " "; 151 } 152 if ($index < $length) { 153 $char = ord(substr($body, $index, 1)); 154 $line .= sprintf("%02x", $char); 155 $ascii .= sprintf("%c", (0x20 <= $char && $char <= 0x7e) ? 156 $char : 0x2e); 157 } else { 158 $line .= " "; 159 $ascii .= " "; 160 } 161 } 162 log_debug(" B %s %s", $line, $ascii); 163 $offset += 16; 164 $length -= 16; 165 substr($body, 0, 16, ""); 166 } 167} 168 169#+++############################################################################ 170# # 171# object oriented interface # 172# # 173#---############################################################################ 174 175# 176# constructor 177# 178# notes: 179# - $self->[I_COMMAND] defaults to SEND so it's always defined 180# - $self->[I_HEADERS] defaults to {} so it's always set to a hash ref 181# - $self->[I_BODY] defaults to \"" so it's always set to a scalar ref 182# 183 184my %new_options = ( 185 "command" => { 186 optional => 1, 187 type => SCALAR, 188 regex => qr/^[A-Z]{2,16}$/, 189 }, 190 "headers" => { 191 optional => 1, 192 type => HASHREF, 193 }, 194 "body_reference" => { 195 optional => 1, 196 type => SCALARREF, 197 }, 198 "body" => { 199 optional => 1, 200 type => SCALAR, 201 }, 202); 203 204sub new : method { 205 my($class, %option, $object); 206 207 if ($Net::STOMP::Client::NoParamsValidation) { 208 ($class, %option) = @_; 209 } else { 210 $class = shift(@_); 211 %option = validate(@_, \%new_options) if @_; 212 } 213 if (defined($option{"body"})) { 214 # handle the convenient body option 215 dief("options body and body_reference are " . 216 "mutually exclusive") if $option{"body_reference"}; 217 $option{"body_reference"} = \ delete($option{"body"}); 218 } 219 $option{"command"} ||= "SEND"; 220 $option{"headers"} ||= {}; 221 $option{"body_reference"} ||= \ ""; 222 $object = [ @option{ qw(command headers body_reference) } ]; 223 return(bless($object, $class)); 224} 225 226# 227# standard getters and setters 228# 229 230sub command : method { 231 my($self, $value); 232 233 $self = shift(@_); 234 return($self->[I_COMMAND]) if @_ == 0; 235 $value = $_[0]; 236 if (@_ == 1 and defined($value) and ref($value) eq "" 237 and $value =~ $new_options{"command"}{"regex"}) { 238 $self->[I_COMMAND] = $value; 239 return($self); 240 } 241 # otherwise complain... 242 validate_pos(@_, $new_options{"command"}); 243} 244 245sub headers : method { 246 my($self, $value); 247 248 $self = shift(@_); 249 return($self->[I_HEADERS]) if @_ == 0; 250 $value = $_[0]; 251 if (@_ == 1 and ref($value) eq "HASH") { 252 $self->[I_HEADERS] = $value; 253 return($self); 254 } 255 # otherwise complain... 256 validate_pos(@_, $new_options{"headers"}); 257} 258 259sub body_reference : method { 260 my($self, $value); 261 262 $self = shift(@_); 263 return($self->[I_BODY]) if @_ == 0; 264 $value = $_[0]; 265 if (@_ == 1 and ref($value) eq "SCALAR") { 266 $self->[I_BODY] = $value; 267 return($self); 268 } 269 # otherwise complain... 270 validate_pos(@_, $new_options{"body_reference"}); 271} 272 273# 274# convenient body getter and setter 275# 276 277sub body : method { 278 my($self, $value); 279 280 $self = shift(@_); 281 return(${ $self->[I_BODY] }) if @_ == 0; 282 $value = $_[0]; 283 if (@_ == 1 and defined($value) and ref($value) eq "") { 284 $self->[I_BODY] = \$value; 285 return($self); 286 } 287 # otherwise complain... 288 validate_pos(@_, $new_options{"body"}); 289} 290 291# 292# convenient individual header getter and setter: 293# - $frame->header($key): get 294# - $frame->header($key, $value): set 295# - $frame->header($key, undef): delete 296# 297 298my @header_options = ( 299 { optional => 0, type => SCALAR }, 300 { optional => 1, type => SCALAR|UNDEF }, 301); 302 303sub header : method { 304 my($self, $key, $value); 305 306 $self = shift(@_); 307 $key = $_[0]; 308 if (defined($key) and ref($key) eq "") { 309 if (@_ == 1) { 310 # get 311 return($self->[I_HEADERS]{$key}); 312 } elsif (@_ == 2) { 313 $value = $_[1]; 314 if (defined($value)) { 315 if (ref($value) eq "") { 316 # set 317 $self->[I_HEADERS]{$key} = $value; 318 return($self); 319 } 320 } else { 321 # delete 322 delete($self->[I_HEADERS]{$key}); 323 return($self); 324 } 325 } 326 } 327 # otherwise complain... 328 validate_pos(@_, @header_options); 329} 330 331#+++############################################################################ 332# # 333# parsing # 334# # 335#---############################################################################ 336 337# 338# parse the given buffer reference and return a hash of pointers to frame parts 339# if the frame is complete or false otherwise; an optional hash can be given to 340# represent state information from a previous parse on the exact same buffer 341# 342# note: for STOMP <1.2, we may miss a final \r in command or header as it would 343# be part of the eol; up to the caller to be strict and check for its presence 344# or to simply ignore this corner case for the sake of simplicity 345# 346 347my %parse_options = ( 348 state => { optional => 1, type => HASHREF }, 349); 350 351sub parse ($@) { ## no critic 'ProhibitExcessComplexity' 352 my($bufref, %option, $state, $index, $buflen, $eol, $tmp); 353 354 # 355 # setup 356 # 357 if ($Net::STOMP::Client::NoParamsValidation) { 358 ($bufref, %option) = @_; 359 } else { 360 validate_pos(@_, { type => SCALARREF }) unless ref($_[0]) eq "SCALAR"; 361 $bufref = shift(@_); 362 %option = validate(@_, \%parse_options) if @_; 363 } 364 $state = $option{state} || {}; 365 # 366 # before: allow 0 or more end-of-line characters 367 # (note: we allow \n and \r\n but also \r as EOL, this should not be a 368 # problem in practice) 369 # 370 unless (exists($state->{before_len})) { 371 return(0) unless ${$bufref} =~ /^[\r\n]*[^\r\n]/g; 372 $state->{before_len} = pos(${$bufref}) - 1; 373 } 374 # 375 # command: everything up to the first EOL 376 # 377 unless (exists($state->{command_len})) { 378 $state->{command_idx} = $state->{before_len}; 379 $index = index(${$bufref}, "\n", $state->{command_idx}); 380 return(0) if $index < 0; 381 $state->{command_len} = $index - $state->{command_idx}; 382 if (substr(${$bufref}, $index - 1, 1) eq "\r") { 383 $state->{command_len}--; 384 $state->{command_eol} = 2; 385 } else { 386 $state->{command_eol} = 1; 387 } 388 } 389 # 390 # header: everything up to the first double EOL 391 # 392 unless (exists($state->{header_len})) { 393 $state->{header_idx} = $state->{command_idx} + $state->{command_len}; 394 $eol = $state->{command_eol}; 395 $tmp = $state->{header_idx} + $eol; 396 while (1) { 397 $index = index(${$bufref}, "\n", $tmp); 398 return(0) if $index < 0; 399 if ($index == $tmp) { 400 $state->{header_eol} = $eol + 1; 401 last; 402 } elsif ($index == $tmp + 1 403 and substr(${$bufref}, $tmp, 1) eq "\r") { 404 $state->{header_eol} = $eol + 2; 405 last; 406 } 407 $eol = substr(${$bufref}, $index - 1, 1) eq "\r" ? 2 : 1; 408 $tmp = $index + 1; 409 } 410 $index -= $state->{header_eol} - 1; 411 if ($index == $state->{header_idx}) { 412 # empty header 413 $state->{header_len} = 0; 414 } else { 415 # non-empty header 416 $state->{header_idx} += $state->{command_eol}; 417 $state->{header_len} = $index - $state->{header_idx}; 418 $tmp = substr(${$bufref}, $state->{header_idx} - 1, 419 $state->{header_len} + 3); 420 $state->{content_length} = $1 421 if $tmp =~ /\ncontent-length *: *(\d+) *\r?\n/; 422 } 423 } 424 # 425 # body: everything up to content-length bytes or the first NULL byte 426 # 427 $buflen = length(${$bufref}); 428 $state->{body_idx} = $state->{header_idx} + $state->{header_len} 429 + $state->{header_eol}; 430 if (exists($state->{content_length})) { 431 # length is known 432 return(0) 433 if $buflen < $state->{body_idx} + $state->{content_length} + 1; 434 $state->{body_len} = $state->{content_length}; 435 $tmp = substr(${$bufref}, $state->{body_idx} + $state->{body_len}, 1); 436 dief("missing NULL byte at end of frame") unless $tmp eq "\0"; 437 } else { 438 # length is not known 439 $index = index(${$bufref}, "\0", $state->{body_idx}); 440 return(0) if $index < 0; 441 $state->{body_len} = $index - $state->{body_idx}; 442 } 443 # 444 # after: allow 0 or more end-of-line characters 445 # (note: we allow \n and \r\n but also \r as EOL, this should not be a 446 # problem in practice) 447 # 448 $state->{after_idx} = $state->{body_idx} + $state->{body_len} + 1; 449 $state->{after_len} = 0; 450 while ($buflen > $state->{after_idx} + $state->{after_len}) { 451 $tmp = substr(${$bufref}, $state->{after_idx} + $state->{after_len}, 1); 452 last unless $tmp eq "\r" or $tmp eq "\n"; 453 $state->{after_len}++; 454 } 455 $state->{total_len} = $state->{after_idx} + $state->{after_len}; 456 # so far so good ;-) 457 return($state); 458} 459 460#+++############################################################################ 461# # 462# decoding # 463# # 464#---############################################################################ 465 466# 467# decode the given string reference and return a frame object if the frame is 468# complete or false otherwise; take the same options as parse() plus debug 469# and version 470# 471# side effect: in case a frame is successfully decoded, the given string is 472# _modified_ to remove the corresponding encoded frame 473# 474 475my %decode_options = ( 476 debug => { optional => 1, type => UNDEF|SCALAR }, 477 state => { optional => 1, type => HASHREF }, 478 strict => { optional => 1, type => BOOLEAN }, 479 version => { optional => 1, type => SCALAR, regex => qr/^1\.\d$/ }, 480); 481 482sub decode ($@) { ## no critic 'ProhibitExcessComplexity' 483 my($bufref, %option, $check, $state, $key, $val, $errors, $tmp, %frame); 484 485 # 486 # setup 487 # 488 if ($Net::STOMP::Client::NoParamsValidation) { 489 ($bufref, %option) = @_; 490 } else { 491 validate_pos(@_, { type => SCALARREF }) unless ref($_[0]) eq "SCALAR"; 492 $bufref = shift(@_); 493 %option = validate(@_, \%decode_options) if @_; 494 } 495 $option{debug} ||= ""; 496 $state = $option{state} || {}; 497 $option{strict} = $StrictEncode unless defined($option{strict}); 498 $option{version} ||= "1.0"; 499 $check = $option{strict} ? Encode::FB_CROAK : Encode::FB_DEFAULT; 500 # 501 # frame parsing 502 # 503 { 504 local $Net::STOMP::Client::NoParamsValidation = 1; 505 $tmp = parse($bufref, state => $state); 506 } 507 return(0) unless $tmp; 508 # 509 # frame debugging 510 # 511 if ($option{debug} =~ /\b(command|all)\b/) { 512 $tmp = substr(${$bufref}, $state->{command_idx}, $state->{command_len}); 513 _debug_command("decoding", $tmp); 514 } 515 if ($option{debug} =~ /\b(header|all)\b/) { 516 $tmp = substr(${$bufref}, $state->{header_idx}, $state->{header_len}); 517 _debug_header($tmp); 518 } 519 if ($option{debug} =~ /\b(body|all)\b/) { 520 $tmp = substr(${$bufref}, $state->{body_idx}, $state->{body_len}); 521 _debug_body($tmp); 522 } 523 # 524 # frame decoding (command) 525 # 526 $frame{"command"} = 527 substr(${$bufref}, $state->{command_idx}, $state->{command_len}); 528 dief("invalid command: %s", $frame{"command"}) 529 unless $frame{"command"} =~ $new_options{"command"}{"regex"}; 530 # 531 # frame decoding (headers) 532 # 533 if ($state->{header_len}) { 534 $frame{"headers"} = {}; 535 $tmp = substr(${$bufref}, $state->{header_idx}, $state->{header_len}); 536 if ($option{version} ge "1.1") { 537 # STOMP >=1.1 behavior: the header is assumed to be UTF-8 encoded 538 $tmp = Encode::decode("UTF-8", $tmp, $check); 539 } 540 if ($option{version} eq "1.0") { 541 # STOMP 1.0 behavior: 542 # - we arbitrarily restrict the header name as a safeguard 543 # - space surrounding the comma and at end of line is not significant 544 # - last header wins (not specified explicitly but reasonable default) 545 foreach my $line (split(/\n/, $tmp)) { 546 if ($line =~ /^($_HeaderNameRE)\s*:\s*(.*?)\s*$/o) { 547 $frame{"headers"}{$1} = $2; 548 } else { 549 dief("invalid header: %s", $line); 550 } 551 } 552 } elsif ($option{version} eq "1.1") { 553 # STOMP 1.1 behavior: 554 # - header names and values can contain any byte except \n or : 555 # - space is significant 556 # - only the first header entry should be used 557 # - handle backslash escaping 558 foreach my $line (split(/\n/, $tmp)) { 559 if ($line =~ /^([^\n\:]+):([^\n\:]*)$/) { 560 ($key, $val, $errors) = ($1, $2, 0); 561 } else { 562 dief("invalid header: %s", $line); 563 } 564 $key =~ s/(\\.)/$_DecMap1{$1}||$errors++/eg; 565 $val =~ s/(\\.)/$_DecMap1{$1}||$errors++/eg; 566 dief("invalid header: %s", $line) if $errors; 567 $frame{"headers"}{$key} = $val 568 unless exists($frame{"headers"}{$key}); 569 } 570 } else { 571 # STOMP 1.2 behavior: 572 # - header names and values can contain any byte except \r or \n or : 573 # - space is significant 574 # - only the first header entry should be used 575 # - handle backslash escaping 576 foreach my $line (split(/\r?\n/, $tmp)) { 577 if ($line =~ /^([^\r\n\:]+):([^\r\n\:]*)$/) { 578 ($key, $val, $errors) = ($1, $2, 0); 579 } else { 580 dief("invalid header: %s", $line) 581 } 582 $key =~ s/(\\.)/$_DecMap2{$1}||$errors++/eg; 583 $val =~ s/(\\.)/$_DecMap2{$1}||$errors++/eg; 584 dief("invalid header: %s", $line) if $errors; 585 $frame{"headers"}{$key} = $val 586 unless exists($frame{"headers"}{$key}); 587 } 588 } 589 } 590 # 591 # frame decoding (body) 592 # 593 if ($state->{body_len}) { 594 $tmp = substr(${$bufref}, $state->{body_idx}, $state->{body_len}); 595 if ($option{version} ge "1.1" and $frame{"headers"}) { 596 # STOMP >=1.1 behavior: the body may be encoded 597 $val = _encoding($frame{"headers"}{"content-type"}); 598 if ($val) { 599 $tmp = Encode::decode($val, $tmp, $check); 600 } 601 } 602 $frame{"body_reference"} = \$tmp; 603 } 604 # 605 # so far so good 606 # 607 substr(${$bufref}, 0, $state->{total_len}, ""); 608 %{ $state } = (); 609 local $Net::STOMP::Client::NoParamsValidation = 1; 610 return(__PACKAGE__->new(%frame)); 611} 612 613#+++############################################################################ 614# # 615# encoding # 616# # 617#---############################################################################ 618 619# 620# encode the given frame object and return a string reference; take the same 621# options as decode() except state 622# 623 624my %encode_options = ( 625 debug => { optional => 1, type => UNDEF|SCALAR }, 626 strict => { optional => 1, type => BOOLEAN }, 627 version => { optional => 1, type => SCALAR, regex => qr/^1\.\d$/ }, 628); 629 630sub encode : method { ## no critic 'ProhibitExcessComplexity' 631 my($self, %option, $check, $header, $tmp); 632 my($body, $bodyref, $bodylen, $conlen, $key, $val); 633 634 # 635 # setup 636 # 637 if ($Net::STOMP::Client::NoParamsValidation) { 638 ($self, %option) = @_; 639 } else { 640 $self = shift(@_); 641 %option = validate(@_, \%encode_options) if @_; 642 } 643 $option{debug} ||= ""; 644 $option{strict} = $StrictEncode unless defined($option{strict}); 645 $option{version} ||= "1.0"; 646 $check = $option{strict} ? Encode::FB_CROAK : Encode::FB_DEFAULT; 647 # 648 # body encoding (must be done first because of the content-length header) 649 # 650 if ($option{version} ge "1.1") { 651 $tmp = _encoding($self->[I_HEADERS]{"content-type"}); 652 } else { 653 $tmp = undef; 654 } 655 if ($tmp) { 656 $body = Encode::encode($tmp, ${ $self->[I_BODY] }, 657 $check | Encode::LEAVE_SRC); 658 $bodyref = \$body; 659 } else { 660 $bodyref = $self->[I_BODY]; 661 } 662 $bodylen = length(${ $bodyref }); 663 # 664 # content-length header handling 665 # 666 $tmp = $self->[I_HEADERS]{"content-length"}; 667 if (defined($tmp)) { 668 # content-length is defined: we use it unless it is the empty string 669 # (which means do not set the content-length even with a body) 670 $conlen = $tmp unless $tmp eq ""; 671 } else { 672 # content-length is not defined (default behavior): we set it to the 673 # body length only if the body is not empty 674 $conlen = $bodylen unless $bodylen == 0; 675 } 676 # 677 # header encoding 678 # 679 $tmp = $self->[I_HEADERS]; 680 if ($option{version} eq "1.0") { 681 # STOMP 1.0 behavior: no backslash escaping 682 $header = join("\n", map($_ . ":" . $tmp->{$_}, 683 grep($_ ne "content-length", keys(%{ $tmp }))), ""); 684 } elsif ($option{version} eq "1.1") { 685 # STOMP 1.1 behavior: backslash escaping 686 $header = ""; 687 while (($key, $val) = each(%{ $tmp })) { 688 next if $key eq "content-length"; 689 $key =~ s/($_EncSet1)/$_EncMap1{$1}/ego; 690 $val =~ s/($_EncSet1)/$_EncMap1{$1}/ego; 691 $header .= $key . ":" . $val . "\n"; 692 } 693 } else { 694 # STOMP 1.2 behavior: backslash escaping 695 $header = ""; 696 while (($key, $val) = each(%{ $tmp })) { 697 next if $key eq "content-length"; 698 $key =~ s/($_EncSet2)/$_EncMap2{$1}/ego; 699 $val =~ s/($_EncSet2)/$_EncMap2{$1}/ego; 700 $header .= $key . ":" . $val . "\n"; 701 } 702 } 703 $header .= "content-length:" . $conlen . "\n" if defined($conlen); 704 if ($option{version} ge "1.1") { 705 # STOMP >=1.1 behavior: the header must be UTF-8 encoded 706 $header = Encode::encode("UTF-8", $header, $check); 707 } 708 # 709 # frame debugging 710 # 711 if ($option{debug} =~ /\b(command|all)\b/) { 712 _debug_command("encoding", $self->[I_COMMAND]); 713 } 714 if ($option{debug} =~ /\b(header|all)\b/) { 715 _debug_header($header); 716 } 717 if ($option{debug} =~ /\b(body|all)\b/) { 718 _debug_body(${ $bodyref }); 719 } 720 # 721 # assemble all the parts 722 # 723 $tmp = $self->[I_COMMAND] . "\n" . $header . "\n" . ${ $bodyref } . "\0"; 724 # return a reference to the encoded frame 725 return(\$tmp); 726} 727 728# 729# FIXME: compatibility hack for Net::STOMP::Client 1.x (to be removed one day) 730# 731 732sub check : method { 733 return(1); 734} 735 736#+++############################################################################ 737# # 738# integration with Messaging::Message # 739# # 740#---############################################################################ 741 742# 743# transform a frame into a message 744# 745 746sub messagify : method { 747 my($self) = @_; 748 749 unless ($Messaging::Message::VERSION) { 750 eval { require Messaging::Message }; 751 dief("cannot load Messaging::Message: %s", $@) if $@; 752 } 753 return(Messaging::Message->new( 754 "header" => $self->headers(), 755 "body_ref" => $self->body_reference(), 756 "text" => _encoding($self->header("content-type")) ? 1 : 0, 757 )); 758} 759 760# 761# transform a message into a frame 762# 763 764sub demessagify ($) { 765 my($message, $frame, $content_type); 766 767 # FIXME: compatibility hack for Net::STOMP::Client 1.x (to be removed one day) 768 if (@_ == 1) { 769 # normal API, to become: my($message) = @_ 770 $message = $_[0]; 771 } elsif (@_ == 2 and $_[0] eq "Net::STOMP::Client::Frame") { 772 # old API, was a class method 773 shift(@_); 774 $message = $_[0]; 775 } 776 validate_pos(@_, { isa => "Messaging::Message" }); 777 $frame = __PACKAGE__->new( 778 "command" => "SEND", 779 "headers" => $message->header(), 780 "body_reference" => $message->body_ref(), 781 ); 782 # handle the text attribute wrt the content-type header 783 $content_type = $frame->header("content-type"); 784 if (defined($content_type)) { 785 # make sure the content-type is consistent with the message type 786 if (_encoding($content_type)) { 787 dief("unexpected text content-type for binary message: %s", 788 $content_type) unless $message->text(); 789 } else { 790 dief("unexpected binary content-type for text message: %s", 791 $content_type) if $message->text(); 792 } 793 } else { 794 # set a text content-type if it is missing (this is needed by STOMP >=1.1) 795 $frame->header("content-type", "text/unknown") if $message->text(); 796 } 797 return($frame); 798} 799 800# 801# export control 802# 803 804sub import : method { 805 my($pkg, %exported); 806 807 $pkg = shift(@_); 808 grep($exported{$_}++, qw(demessagify)); 809 export_control(scalar(caller()), $pkg, \%exported, @_); 810} 811 8121; 813 814__END__ 815 816=head1 NAME 817 818Net::STOMP::Client::Frame - Frame support for Net::STOMP::Client 819 820=head1 SYNOPSIS 821 822 use Net::STOMP::Client::Frame qw(); 823 824 # create a connection frame 825 $frame = Net::STOMP::Client::Frame->new( 826 command => "CONNECT", 827 headers => { 828 login => "guest", 829 passcode => "guest", 830 }, 831 ); 832 833 # get the command 834 $cmd = $frame->command(); 835 836 # set the body 837 $frame->body("...some data..."); 838 839 # directly get a header field 840 $msgid = $frame->header("message-id"); 841 842=head1 DESCRIPTION 843 844This module provides an object oriented interface to manipulate STOMP 845frames. 846 847A frame object has the following attributes: C<command>, C<headers> and 848C<body_reference>. The C<headers> attribute must be a reference to a hash of 849header key/value pairs. The body is usually manipulated by reference to 850avoid string copies. 851 852=head1 METHODS 853 854This module provides the following methods: 855 856=over 857 858=item new([OPTIONS]) 859 860return a new Net::STOMP::Client::Frame object (class method); the options 861that can be given (C<command>, C<headers>, C<body_reference> and C<body>) 862match the accessors described below 863 864=item command([STRING]) 865 866get/set the C<command> attribute 867 868=item headers([HASHREF]) 869 870get/set the C<headers> attribute 871 872=item body_reference([STRINGREF]) 873 874get/set the C<body_reference> attribute 875 876=item header(NAME[, VALUE]) 877 878get/set the value associated with the given name in the header; if the given 879value is undefined, remove the named header (this is a convenient wrapper 880around the headers() method) 881 882=item body([STRING]) 883 884get/set the body as a string (this is a convenient wrapper around the 885body_reference() method) 886 887=item encode([OPTIONS]) 888 889encode the given frame and return a reference to a binary string suitable to 890be written to a TCP stream (for instance); supported options: 891C<debug> (debugging flags as a string), 892C<strict> (the desired strictness, overriding $StrictEncode), 893C<version> (the STOMP protocol version to use) 894 895=item check([OPTIONS]) 896 897this method is obsolete and should not be used anymore; it is left here only 898to provide backward compatibility with Net::STOMP::Client 1.x 899 900=back 901 902=head1 FUNCTIONS 903 904This module provides the following functions (which are B<not> exported): 905 906=over 907 908=item decode(STRINGREF, [OPTIONS]) 909 910decode the given string reference and return a complete frame object, if 911possible or false in case there is not enough data for a complete frame; 912supported options: the same as encode() plus parse() 913 914=item parse(STRINGREF, [OPTIONS]) 915 916parse the given string reference and return true if a complete frame is 917found or false otherwise; supported options: C<state> (a hash reference that 918holds the parsing state); see the L<"FRAME PARSING"> section for more 919information 920 921=back 922 923=head1 VARIABLES 924 925This module uses the following global variables (which are B<not> exported): 926 927=over 928 929=item $Net::STOMP::Client::Frame::DebugBodyLength 930 931the maximum number of bytes to dump when debugging message bodies 932(default: 256) 933 934=item $Net::STOMP::Client::Frame::StrictEncode 935 936whether or not to perform strict character encoding/decoding 937(default: false) 938 939=back 940 941=head1 FRAME PARSING 942 943The parse() function can be used to parse a frame without decoding it. 944 945It takes as input a binary string reference (to avoid string copies) and an 946optional state (a hash reference). It parses the string to find out where 947the different parts of the frames are and it updates its state (if given). 948 949It returns false if the string does not hold a complete frame or a hash 950reference if a complete frame is present. This hash is in fact the same 951thing as the state and it contains the following keys: 952 953=over 954 955=item before_len 956 957the length of what is found before the frame (only frame EOL can appear 958here) 959 960=item command_idx, command_len, command_eol 961 962the start position, length and length of the EOL of the command 963 964=item header_idx, header_len, header_eol 965 966the start position, length and length of the EOL of the header 967 968=item body_idx, body_len 969 970the start position and length of the body 971 972=item after_idx, after_len 973 974the length of what is found after the frame (only frame EOL can appear here) 975 976=item content_length 977 978the value of the C<content-length> header (if present) 979 980=item total_len 981 982the total length of the frame, including before and after parts 983 984=back 985 986Here is how this could be used: 987 988 $data = "... read from socket or file ..."; 989 $info = Net::STOMP::Client::Frame::parse(\$data); 990 if ($info) { 991 # extract interesting frame parts 992 $command = substr($data, $info->{command_idx}, $info->{command_len}); 993 # remove the frame from the buffer 994 substr($data, 0, $info->{total_len}) = ""; 995 } 996 997=head1 CONTENT LENGTH 998 999The C<content-length> header is special because it is sometimes used to 1000indicate the length of the body but also the JMS type of the message in 1001ActiveMQ as per L<http://activemq.apache.org/stomp.html>. 1002 1003If you do not supply a C<content-length> header, following the protocol 1004recommendations, a C<content-length> header will be added if the frame has a 1005body. 1006 1007If you do supply a numerical C<content-length> header, it will be used as 1008is. Warning: this may give unexpected results if the supplied value does not 1009match the body length. Use only with caution! 1010 1011Finally, if you supply an empty string as the C<content-length> header, it 1012will not be sent, even if the frame has a body. This can be used to mark a 1013message as being a TextMessage for ActiveMQ. Here is an example of this: 1014 1015 $stomp->send( 1016 "destination" => "/queue/test", 1017 "body" => "hello world!", 1018 "content-length" => "", 1019 ); 1020 1021=head1 ENCODING 1022 1023The STOMP 1.0 specification does not define which encoding should be used to 1024serialize frames. So, by default, this module assumes that what has been 1025given by the user or by the server is a ready-to-use sequence of bytes and 1026it does not perform any further encoding or decoding. 1027 1028If $Net::STOMP::Client::Frame::StrictEncode is true, all encoding and 1029decoding operations will be stricter and will report a fatal error when 1030given malformed input. This is done by using the Encode::FB_CROAK flag 1031instead of the default Encode::FB_DEFAULT. 1032 1033N.B.: Perl's standard L<Encode> module is used for all encoding/decoding 1034operations. 1035 1036=head1 MESSAGING ABSTRACTION 1037 1038If the L<Messaging::Message> module is available, the following method and 1039function are available too: 1040 1041=over 1042 1043=item messagify() 1044 1045transform the frame into a Messaging::Message object (method) 1046 1047=item demessagify(MESSAGE) 1048 1049transform the given Messaging::Message object into a 1050Net::STOMP::Client::Frame object (function) 1051 1052=back 1053 1054Here is how they could be used: 1055 1056 # frame to message 1057 $frame = $stomp->wait_for_frames(timeout => 1); 1058 if ($frame) { 1059 $message = $frame->messagify(); 1060 ... 1061 } 1062 1063 # message to frame 1064 $frame = Net::STOMP::Client::Frame::demessagify($message); 1065 $stomp->send_frame($frame); 1066 1067Note: in both cases, string copies are avoided so both objects will share 1068the same header hash and body string. Therefore modifying one may also 1069modify the other. Clone (copy) the objects if you do not want this behavior. 1070 1071=head1 COMPLIANCE 1072 1073STOMP 1.0 has several ambiguities and this module does its best to work "as 1074expected" in these gray areas. 1075 1076STOMP 1.1 and STOMP 1.2 are much better specified and this module should be 1077fully compliant with these STOMP specifications with only one exception: by 1078default, this module is permissive and allows malformed encoded data (this 1079is the same default as the L<Encode> module itself); to be more strict, set 1080$Net::STOMP::Client::Frame::StrictEncode to true (as explained above). 1081 1082=head1 SEE ALSO 1083 1084L<Encode>, 1085L<Messaging::Message>, 1086L<Net::STOMP::Client>. 1087 1088=head1 AUTHOR 1089 1090Lionel Cons L<http://cern.ch/lionel.cons> 1091 1092Copyright (C) CERN 2010-2017 1093