| 1 | package Inline::denter; |
| 2 | |
| 3 | use strict; |
| 4 | use Carp; |
| 5 | use AutoLoader 'AUTOLOAD'; |
| 6 | |
| 7 | sub new { |
| 8 | my $class = shift; |
| 9 | bless {width => 4, |
| 10 | comma => " : ", |
| 11 | level => 0, |
| 12 | tabwidth => 8, |
| 13 | }, $class; |
| 14 | } |
| 15 | |
| 16 | sub undent { |
| 17 | local $/ = "\n"; |
| 18 | my ($o, $text) = @_; |
| 19 | my ($comma) = $o->{comma}; |
| 20 | my $package = caller; |
| 21 | $package = caller(1) if $package eq 'Inline::denter'; |
| 22 | %{$o->{xref}} = (); |
| 23 | @{$o->{objects}} = (); |
| 24 | @{$o->{context}} = (); |
| 25 | my $glob = ''; |
| 26 | chomp $text; |
| 27 | @{$o->{lines}} = split $/, $text; |
| 28 | $o->{level} = 0; |
| 29 | $o->{line} ||= 1; |
| 30 | $o->_setup_line; |
| 31 | while (not $o->{done}) { |
| 32 | if ($o->{level} == 0 and |
| 33 | $o->{content} =~ /^(\w+)\s*$comma\s*(.*)$/) { |
| 34 | $o->{content} = $2; |
| 35 | no strict 'refs'; |
| 36 | push @{$o->{objects}}, "$1"; |
| 37 | } |
| 38 | push @{$o->{objects}}, $o->_undent_data; |
| 39 | } |
| 40 | return @{$o->{objects}}; |
| 41 | } |
| 42 | |
| 43 | sub _undent_data { |
| 44 | my $o = shift; |
| 45 | my ($obj, $class) = ('', ''); |
| 46 | my @refs; |
| 47 | my %refs; |
| 48 | while ($o->{content} =~ s/^\\(?:\((\w+)\))?((\%|\@|\$|\\).*)/$2/) { |
| 49 | push @refs, $1; |
| 50 | $refs{$1} = scalar @refs; |
| 51 | } |
| 52 | if ($o->{content} =~ /^([\%\@\$]) |
| 53 | (\w(?:\w|::)*)? |
| 54 | \s*$/x |
| 55 | ) { |
| 56 | my $foo; |
| 57 | $obj = ($1 eq '%') ? {} : ($1 eq '@') ? [] : \$foo; |
| 58 | $class = $2 || ''; |
| 59 | if ($1 eq '%') { |
| 60 | %$obj = $o->_undent_hash; |
| 61 | } |
| 62 | elsif ($1 eq '@') { |
| 63 | @$obj = $o->_undent_array; |
| 64 | } |
| 65 | else { |
| 66 | $$obj = $o->_undent_scalar; |
| 67 | } |
| 68 | bless $obj, $class if length $class; |
| 69 | } |
| 70 | elsif ($o->{content} =~ /^\?\s*$/) { |
| 71 | $obj = $o->_undent_undef; |
| 72 | } |
| 73 | else { |
| 74 | $obj = $o->_undent_value; |
| 75 | } |
| 76 | while (@refs) { |
| 77 | my $ref = pop @refs; |
| 78 | my $copy = $obj; |
| 79 | $obj = \ $copy; |
| 80 | $o->{xref}{$ref} = $obj if $ref; |
| 81 | } |
| 82 | return $obj; |
| 83 | } |
| 84 | |
| 85 | sub _undent_value { |
| 86 | my $o = shift; |
| 87 | my $value = ''; |
| 88 | if ($o->{content} =~ /^\<\<(\w+)(\-?)\s*$/) { |
| 89 | my ($marker, $chomp) = ($1, $2); |
| 90 | my $line = $o->{line}; |
| 91 | $o->_next_line; |
| 92 | while (not $o->{done} and |
| 93 | $o->{lines}[0] ne $marker) { |
| 94 | $value .= $o->{lines}[0] . "\n"; |
| 95 | $o->_next_line; |
| 96 | } |
| 97 | croak M03_no_value_end_marker($marker, $line) if $o->{done}; |
| 98 | chomp $value if $chomp; |
| 99 | } |
| 100 | elsif ($o->{content} =~ /^\"/) { |
| 101 | croak $o->M04_mismatched_quotes unless $o->{content} =~ /^\".*\"\s*$/; |
| 102 | ($value = $o->{content}) =~ s/^\"|\"\s*$//g; |
| 103 | } |
| 104 | else { |
| 105 | $value = $o->{content}; |
| 106 | } |
| 107 | $o->_next_line; |
| 108 | $o->_setup_line; |
| 109 | return $value; |
| 110 | } |
| 111 | |
| 112 | sub _undent_hash { |
| 113 | my @values; |
| 114 | my $o = shift; |
| 115 | my $level = $o->{level} + 1; |
| 116 | $o->_next_line; |
| 117 | $o->_setup_line; |
| 118 | while ($o->{level} == $level) { |
| 119 | my ($key, $value) = split $o->{comma}, $o->{content}; |
| 120 | croak $o->M05_invalid_key_value unless (defined $key and defined $value); |
| 121 | $o->{content} = $value; |
| 122 | push @values, $o->_get_key($key), $o->_undent_data;; |
| 123 | } |
| 124 | croak $o->M06_invalid_indent_level if $o->{level} > $level; |
| 125 | return @values; |
| 126 | } |
| 127 | |
| 128 | sub _get_key { |
| 129 | my ($o, $key) = @_; |
| 130 | return $key unless $key =~ /^\<\<(\w+)(\-?)/; |
| 131 | my ($marker, $chomp) = ($1, $2); |
| 132 | $key = ''; |
| 133 | my $line = $o->{line}; |
| 134 | $o->_next_line; |
| 135 | while (not $o->{done} and |
| 136 | $o->{lines}[0] ne $marker) { |
| 137 | $key .= $o->{lines}[0] . "\n"; |
| 138 | $o->_next_line; |
| 139 | } |
| 140 | croak M02_no_key_end_marker($marker, $line) if $o->{done}; |
| 141 | chomp $key if $chomp; |
| 142 | $o->_next_line; |
| 143 | $o->_setup_line; |
| 144 | return $key; |
| 145 | } |
| 146 | |
| 147 | sub _undent_array { |
| 148 | my @values; |
| 149 | my $o = shift; |
| 150 | my $level = $o->{level} + 1; |
| 151 | $o->_next_line; |
| 152 | $o->_setup_line; |
| 153 | while ($o->{level} == $level) { |
| 154 | push @values, $o->_undent_data; |
| 155 | } |
| 156 | croak $o->M06_invalid_indent_level if $o->{level} > $level; |
| 157 | return @values; |
| 158 | } |
| 159 | |
| 160 | sub _undent_scalar { |
| 161 | my $values; |
| 162 | my $o = shift; |
| 163 | my $level = $o->{level} + 1; |
| 164 | $o->_next_line; |
| 165 | $o->_setup_line; |
| 166 | croak $o->M06_invalid_indent_level if $o->{level} != $level; |
| 167 | croak $o->M07_invalid_scalar_value if $o->{content} =~ /^[\%\@\$\\]/; |
| 168 | return $o->_undent_undef if $o->{content} =~ /^\?/; |
| 169 | return $o->_undent_value; |
| 170 | } |
| 171 | |
| 172 | sub _undent_undef { |
| 173 | my $o = shift; |
| 174 | $o->_next_line; |
| 175 | $o->_setup_line; |
| 176 | return undef; |
| 177 | } |
| 178 | |
| 179 | sub _next_line { |
| 180 | my $o = shift; |
| 181 | $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}}; |
| 182 | $_ = shift @{$o->{lines}}; |
| 183 | $o->{line}++; |
| 184 | } |
| 185 | |
| 186 | sub _setup_line { |
| 187 | my $o = shift; |
| 188 | $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}}; |
| 189 | my ($width, $tabwidth) = @{$o}{qw(width tabwidth)}; |
| 190 | while (1) { |
| 191 | $_ = $o->{lines}[0]; |
| 192 | # expand tabs in leading whitespace; |
| 193 | $o->next_line, next if /^(\s*$|\#)/; # skip comments and blank lines |
| 194 | while (s{^( *)(\t+)} |
| 195 | {' ' x (length($1) + length($2) * $tabwidth - |
| 196 | length($1) % $tabwidth)}e){} |
| 197 | croak $o->M01_invalid_indent_width unless /^(( {$width})*)(\S.*)$/; |
| 198 | $o->{level} = length($1) / $width; |
| 199 | $o->{content} = $3; |
| 200 | last; |
| 201 | } |
| 202 | } |
| 203 | |
| 204 | 1; |
| 205 | __END__ |
| 206 | |
| 207 | sub indent { |
| 208 | my $o = shift; |
| 209 | my $package = caller; |
| 210 | $package = caller(1) if $package eq 'Inline::denter'; |
| 211 | my $stream = ''; |
| 212 | $o->{key} = ''; |
| 213 | while (@_) { |
| 214 | $_ = shift; |
| 215 | $stream .= $o->indent_name($_, shift), next |
| 216 | if (/^\*$package\::\w+$/); |
| 217 | $stream .= $o->indent_data($_); |
| 218 | } |
| 219 | return $stream; |
| 220 | } |
| 221 | |
| 222 | sub indent_data { |
| 223 | my $o = shift; |
| 224 | $_ = shift; |
| 225 | return $o->indent_undef($_) |
| 226 | if not defined; |
| 227 | return $o->indent_value($_) |
| 228 | if (not ref); |
| 229 | return $o->indent_hash($_) |
| 230 | if (ref eq 'HASH' and not /=/ or /=HASH/); |
| 231 | return $o->indent_array($_) |
| 232 | if (ref eq 'ARRAY' and not /=/ or /=ARRAY/); |
| 233 | return $o->indent_scalar($_) |
| 234 | if (ref eq 'SCALAR' and not /=/ or /=SCALAR/); |
| 235 | return $o->indent_ref($_) |
| 236 | if (ref eq 'REF'); |
| 237 | return "$_\n"; |
| 238 | } |
| 239 | |
| 240 | sub indent_value { |
| 241 | my ($o, $data) = @_; |
| 242 | my $stream; |
| 243 | if ($data =~ /\n/) { |
| 244 | my $marker = 'EOV'; |
| 245 | $marker++ while $data =~ /^$marker$/m; |
| 246 | my $chomp = ($data =~ s/\n\Z//) ? '' : '-'; |
| 247 | $stream = "<<$marker$chomp\n"; |
| 248 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; |
| 249 | $stream .= "$data\n$marker\n"; |
| 250 | } |
| 251 | elsif ($data =~ /^[\s\%\@\$\\?\"]|\s$/ or |
| 252 | $data =~ /\Q$o->{comma}\E/ or |
| 253 | $data =~ /[\x00-\x1f]/ or |
| 254 | $data eq '') { |
| 255 | $stream = qq{"$data"\n}; |
| 256 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; |
| 257 | } |
| 258 | else { |
| 259 | $stream = "$data\n"; |
| 260 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; |
| 261 | } |
| 262 | return $stream; |
| 263 | } |
| 264 | |
| 265 | sub indent_hash { |
| 266 | my ($o, $data) = @_; |
| 267 | my $stream = $o->_print_ref($data, '%', 'HASH'); |
| 268 | return $$stream if ref $stream; |
| 269 | my $indent = ++$o->{level} * $o->{width}; |
| 270 | for my $key (sort keys %$data) { |
| 271 | my $key_out = $key; |
| 272 | if ($key =~ /\n/ or |
| 273 | $key =~ /\Q$o->{comma}\E/) { |
| 274 | my $marker = 'EOK'; |
| 275 | $marker++ while $key =~ /^$marker$/m; |
| 276 | my $chomp = (($o->{key} = $key) =~ s/\n\Z//m) ? '' : '-'; |
| 277 | $o->{key} .= "\n$marker\n"; |
| 278 | $key_out = "<<$marker$chomp"; |
| 279 | } |
| 280 | elsif ($data =~ /^[\s\%\@\$\\?\"]|\s$/) { |
| 281 | $key_out = qq{"$key"}; |
| 282 | } |
| 283 | $stream .= ' ' x $indent . $key_out . $o->{comma}; |
| 284 | $stream .= $o->indent_data($data->{$key}); |
| 285 | } |
| 286 | $o->{level}--; |
| 287 | return $stream; |
| 288 | } |
| 289 | |
| 290 | sub indent_array { |
| 291 | my ($o, $data) = @_; |
| 292 | my $stream = $o->_print_ref($data, '@', 'ARRAY'); |
| 293 | return $$stream if ref $stream; |
| 294 | my $indent = ++$o->{level} * $o->{width}; |
| 295 | for my $datum (@$data) { |
| 296 | $stream .= ' ' x $indent; |
| 297 | $stream .= $o->indent_data($datum); |
| 298 | } |
| 299 | $o->{level}--; |
| 300 | return $stream; |
| 301 | } |
| 302 | |
| 303 | sub indent_scalar { |
| 304 | my ($o, $data) = @_; |
| 305 | my $stream = $o->_print_ref($data, q{$}, 'SCALAR'); |
| 306 | return $$stream if ref $stream; |
| 307 | my $indent = ($o->{level} + 1) * $o->{width}; |
| 308 | $stream .= ' ' x $indent; |
| 309 | $stream .= $o->indent_data($$data); |
| 310 | return $stream; |
| 311 | } |
| 312 | |
| 313 | sub indent_ref { |
| 314 | my ($o, $data) = @_; |
| 315 | my $stream = $o->_print_ref($data, '\\', 'SCALAR'); |
| 316 | return $$stream if ref $stream; |
| 317 | chomp $stream; |
| 318 | return $stream . $o->indent_data($$data); |
| 319 | } |
| 320 | |
| 321 | sub indent_undef { |
| 322 | my ($o, $data) = @_; |
| 323 | my $stream = "?\n"; |
| 324 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; |
| 325 | return $stream; |
| 326 | } |
| 327 | |
| 328 | sub indent_name { |
| 329 | my ($o, $name, $value) = @_; |
| 330 | $name =~ s/^.*:://; |
| 331 | my $stream = $name . $o->{comma}; |
| 332 | $stream .= $o->indent_data($value); |
| 333 | return $stream; |
| 334 | } |
| 335 | |
| 336 | sub _print_ref { |
| 337 | my ($o, $data, $symbol, $type) = @_; |
| 338 | $data =~ /^(([\w:]+)=)?$type\(0x([0-9a-f]+)\)$/ |
| 339 | or croak "Invalid reference: $data\n"; |
| 340 | my $stream = $symbol; |
| 341 | $stream .= $2 if defined $2; |
| 342 | $o->{xref}{$3}++; |
| 343 | croak "Inline::denter does not handle duplicate references" |
| 344 | if $o->{xref}{$3} > 1; |
| 345 | $stream .= "\n"; |
| 346 | $stream .= $o->{key}, $o->{key} = '' if $o->{key}; |
| 347 | return $stream; |
| 348 | } |
| 349 | |
| 350 | # Undent error messages |
| 351 | sub M01_invalid_indent_width { |
| 352 | my $o = shift; |
| 353 | "Invalid indent width detected at line $o->{line}\n"; |
| 354 | } |
| 355 | |
| 356 | sub M02_no_key_end_marker { |
| 357 | my ($marker, $line) = @_; |
| 358 | "No terminating marker '$marker' found for key at line $line\n"; |
| 359 | } |
| 360 | |
| 361 | sub M03_no_value_end_marker { |
| 362 | my ($marker, $line) = @_; |
| 363 | "No terminating marker '$marker' found for value at line $line\n"; |
| 364 | } |
| 365 | |
| 366 | sub M04_mismatched_quotes { |
| 367 | my $o = shift; |
| 368 | "Mismatched double quotes for value at line $o->{line}\n"; |
| 369 | } |
| 370 | |
| 371 | sub M05_invalid_key_value { |
| 372 | my $o = shift; |
| 373 | "Missing or invalid hash key/value pair at $o->{line}\n"; |
| 374 | } |
| 375 | |
| 376 | sub M06_invalid_indent_level { |
| 377 | my $o = shift; |
| 378 | "Invalid indentation level at $o->{line}\n"; |
| 379 | } |
| 380 | |
| 381 | sub M07_invalid_scalar_value { |
| 382 | my $o = shift; |
| 383 | "Invalid value for scalar ref context at $o->{line}\n"; |
| 384 | } |
| 385 | |
| 386 | 1; |
| 387 | __END__ |