123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103
  1. package SugarTrail::STM;
  2. # STM holder
  3. # new()
  4. # parse_headers()
  5. use strict;
  6. use warnings;
  7. use Carp;
  8. use SugarTrail::STS;
  9. sub new {
  10. my $class = shift;
  11. my $args = { @_ };
  12. my $self = {};
  13. $self->{args} = $args;
  14. return bless $self, $class;
  15. }
  16. sub parse_headers {
  17. my $self = shift;
  18. my ($head, $body) = split "\n\n", $self->{text}, 2;
  19. my @lines = split "\n", $head;
  20. $self->{head} = $head;
  21. $self->{body} = $body;
  22. foreach (@lines) {
  23. my ($n, $v) = split ": ", $_, 2;
  24. $self->{meta}->{$n} = $v;
  25. }
  26. return scalar keys %{ $self->{meta} };
  27. }
  28. sub parse_body {
  29. my $self = shift;
  30. my @lines = split "\n", $self->{body};
  31. $self->{steps} = [];
  32. foreach (@lines) {
  33. chomp;
  34. s/ *$//;
  35. my ($line, $cond) = $_ =~ m/^(.*?)(\{(.*)\})?$/;
  36. $line =~ s/ *$//;
  37. push @{ $self->{steps} }, { line => $line, cond => $cond };
  38. }
  39. return scalar @{ $self->{steps} };
  40. }
  41. sub generate_sts {
  42. my $self = shift;
  43. my $args = shift;
  44. my $sts = SugarTrail::STS->new($args);
  45. my @lines;
  46. STEP: foreach (@{ $self->{steps} }) {
  47. unless ($_->{cond}) {
  48. push @lines, $_->{line};
  49. next STEP;
  50. } else {
  51. push @lines, $_->{line} if &matches($_->{cond}, $args);
  52. }
  53. }
  54. $sts->{meta}->{'Stm'} = $self->{stm};
  55. $sts->{meta}->{'Stm Revision'} = $self->get_current_revision();
  56. $sts->{meta}->{'Params'} = mkmymime($args);
  57. $sts->{lines} = \@lines;
  58. return $sts;
  59. }
  60. # skel: matches if cond has m
  61. sub matches {
  62. my $cond = shift;
  63. my $args = shift;
  64. $cond =~ m/m/;
  65. }
  66. # skel: returns time (might be useful in absence of VCS)
  67. sub get_current_revision {
  68. return time;
  69. }
  70. sub mkmymime {
  71. my $d = shift;
  72. my $d1 = "; "; my $d2 = "=";
  73. my @t;
  74. foreach (sort keys %$d) {
  75. push @t, $_ . $d2 . $d->{$_};
  76. }
  77. return join $d1, @t;
  78. }
  79. 1;